-- | Parsing options supplied on the command line
module Test.Tasty.CmdLine
  ( optionParser
  , suiteOptions
  , suiteOptionParser
  , parseOptions
  , defaultMainWithIngredients
  ) where

import Control.Arrow
import Control.Monad
import Data.Maybe
import Data.Proxy
import Data.Typeable (typeOf1)
import Options.Applicative
import Options.Applicative.Common (evalParser)
import qualified Options.Applicative.Types as Applicative (Option(..))
import Options.Applicative.Types (Parser(..), OptProperties(..))
import Prelude  -- Silence AMP and FTP import warnings
import System.Exit
import System.IO
#if !MIN_VERSION_base(4,11,0)
import Data.Foldable (foldMap)
import Data.Monoid (mempty)
import Data.Semigroup (Semigroup((<>)))
#endif

import Test.Tasty.Core
import Test.Tasty.Runners.Utils
import Test.Tasty.Ingredients
import Test.Tasty.Options
import Test.Tasty.Options.Env
import Test.Tasty.Runners.Reducers

-- | Generate a command line parser from a list of option descriptions,
-- alongside any related warning messages.
--
-- @since 1.3
optionParser :: [OptionDescription] -> ([String], Parser OptionSet)
optionParser :: [OptionDescription] -> ([String], Parser OptionSet)
optionParser = (Ap Parser OptionSet -> Parser OptionSet)
-> ([String], Ap Parser OptionSet) -> ([String], Parser OptionSet)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Ap Parser OptionSet -> Parser OptionSet
forall (f :: * -> *) a. Ap f a -> f a
getApp (([String], Ap Parser OptionSet) -> ([String], Parser OptionSet))
-> ([OptionDescription] -> ([String], Ap Parser OptionSet))
-> [OptionDescription]
-> ([String], Parser OptionSet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OptionDescription -> ([String], Ap Parser OptionSet))
-> [OptionDescription] -> ([String], Ap Parser OptionSet)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap OptionDescription -> ([String], Ap Parser OptionSet)
toSet where
  toSet :: OptionDescription -> ([String], Ap Parser OptionSet)
  toSet :: OptionDescription -> ([String], Ap Parser OptionSet)
toSet (Option Proxy v
p) = (Parser v -> Ap Parser OptionSet)
-> ([String], Parser v) -> ([String], Ap Parser OptionSet)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second
    (\Parser v
parser -> 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
parser) 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)
    (Proxy v -> Parser v -> ([String], Parser v)
forall (proxy :: * -> *) v.
IsOption v =>
proxy v -> Parser v -> ([String], Parser v)
finalizeCLParser Proxy v
p Parser v
forall v. IsOption v => Parser v
optionCLParser)

-- Do two things:
--
-- 1. Replace an `optionCLParser`'s 'propShowDefault' with 'showDefaultValue'
--    from the 'IsOption' class.
-- 2. Generate warning messages if the 'optionCLParser' does anything
--    suspicious. Currently, the only suspicious things we check for are
--    (a) if the 'Parser' defines multiple options and, (b) if the 'Parser'
--    assigns a default value outside of 'defaultValue'.
finalizeCLParser :: forall proxy v . IsOption v
                 => proxy v -> Parser v -> ([String], Parser v)
finalizeCLParser :: proxy v -> Parser v -> ([String], Parser v)
finalizeCLParser proxy v
_ Parser v
p = ([String]
warnings, Maybe String -> Parser v -> Parser v
forall a. Maybe String -> Parser a -> Parser a
setCLParserShowDefaultValue Maybe String
mbDef Parser v
p)
  where
    mbDef :: Maybe String
    mbDef :: Maybe String
mbDef = v -> Maybe String
forall v. IsOption v => v -> Maybe String
showDefaultValue (v
forall v. IsOption v => v
defaultValue :: v)

    warnings :: [String]
    warnings :: [String]
warnings = [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String
multipleOptPsWarning, Maybe String
badDefaultWarning]

    -- Warn if a Parser defines multiple options, as this breaks an assumption
    -- that setCLParserShowDefaultValue relies on.
    multipleOptPsWarning :: Maybe String
    multipleOptPsWarning :: Maybe String
multipleOptPsWarning
      | Parser v -> Int
forall a. Parser a -> Int
numOptPs Parser v
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
      = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
        [ String
prov
        , String
"optionCLParser defines multiple options. Consider only defining"
        , String
"a single option here, as defining multiple options does not play"
        , String
"well with how tasty displays default values."
        ]
      | Bool
otherwise
      = Maybe String
forall a. Maybe a
Nothing

    -- Warning if a Parser has a default value (outside of IsOption's
    -- defaultValue method, that is), as this interferes with tasty's ability
    -- to read arguments from environment variables. For more on this point,
    -- see the Haddocks for optionCLParser.
    badDefaultWarning :: Maybe String
    badDefaultWarning :: Maybe String
badDefaultWarning
      -- evalParser will only return Just if has a default value declared with
      -- e.g. the Options.Applicative.value function.
      | Maybe v -> Bool
forall a. Maybe a -> Bool
isJust (Parser v -> Maybe v
forall a. Parser a -> Maybe a
evalParser Parser v
p)
      = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
        [ String
prov
        , String
"Using default values (e.g., with Options.Applicative.value) in"
        , String
"optionCLParser is prohibited, as it interferes with tasty's ability"
        , String
"to read environment variable options properly. Moreover, assigning"
        , String
"default values is unnecessary, as their functionality is subsumed"
        , String
"by the defaultValue method of IsOption."
        ]
      | Bool
otherwise
      = Maybe String
forall a. Maybe a
Nothing

    prov :: String
    prov :: String
prov = String
"WARNING (in the IsOption instance for "
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Proxy v -> TypeRep
forall (t :: * -> *) a. Typeable t => t a -> TypeRep
typeOf1 (Proxy v
forall k (t :: k). Proxy t
Proxy :: Proxy v)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"):"

-- Replace an `optionCLParser`'s 'propShowDefault' with 'showDefaultValue' from
-- the 'IsOption' class. It's tempting to try doing this when constructing the
-- 'Parser' itself using 'optionMod', but @optparse-applicative@'s 'mkParser'
-- function always overrides the result of 'optionMod'. Ugh.
setCLParserShowDefaultValue :: Maybe String -> Parser a -> Parser a
setCLParserShowDefaultValue :: Maybe String -> Parser a -> Parser a
setCLParserShowDefaultValue Maybe String
mbDef = Parser a -> Parser a
forall a. Parser a -> Parser a
go
  where
    go :: Parser a -> Parser a
    -- Note that we /always/ replace the Option's optProps, regardless of
    -- what type it may have. This can produce unexpected results if an
    -- optionCLParser defines multiple options, which is why we emit a warning
    -- (in finalizeCLParser) if a Parser does this.
    go :: Parser a -> Parser a
go (OptP Option a
o)      = Option a -> Parser a
forall a. Option a -> Parser a
OptP Option a
o{optProps :: OptProperties
Applicative.optProps =
                              OptProperties -> OptProperties
modifyDefault (Option a -> OptProperties
forall a. Option a -> OptProperties
Applicative.optProps Option a
o)}
    go p :: Parser a
p@NilP{}      = Parser a
p
    go (MultP Parser (x -> a)
p1 Parser x
p2) = Parser (x -> a) -> Parser x -> Parser a
forall a x. Parser (x -> a) -> Parser x -> Parser a
MultP (Parser (x -> a) -> Parser (x -> a)
forall a. Parser a -> Parser a
go Parser (x -> a)
p1) (Parser x -> Parser x
forall a. Parser a -> Parser a
go Parser x
p2)
    go (AltP  Parser a
p1 Parser a
p2) = Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
AltP  (Parser a -> Parser a
forall a. Parser a -> Parser a
go Parser a
p1) (Parser a -> Parser a
forall a. Parser a -> Parser a
go Parser a
p2)
    go (BindP Parser x
p1 x -> Parser a
p2) = Parser x -> (x -> Parser a) -> Parser a
forall a x. Parser x -> (x -> Parser a) -> Parser a
BindP (Parser x -> Parser x
forall a. Parser a -> Parser a
go Parser x
p1) ((Parser a -> Parser a) -> (x -> Parser a) -> x -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Parser a -> Parser a
forall a. Parser a -> Parser a
go x -> Parser a
p2)

    modifyDefault :: OptProperties -> OptProperties
    modifyDefault :: OptProperties -> OptProperties
modifyDefault OptProperties
op = OptProperties
op{propShowDefault :: Maybe String
propShowDefault = Maybe String
mbDef}

-- Note: this is a conservative estimate, since we cannot count the number
-- of OptPs in the continuation argument of BindP. But BindP is really only
-- used for ParserM purposes, and since ParserM is an internal
-- optparse-applicative definition, most optionCLParser instances are
-- unlikely to use it in practice.
numOptPs :: Parser a -> Int
numOptPs :: Parser a -> Int
numOptPs OptP{} = Int
1
numOptPs NilP{} = Int
0
numOptPs (MultP Parser (x -> a)
p1  Parser x
p2) = Parser (x -> a) -> Int
forall a. Parser a -> Int
numOptPs Parser (x -> a)
p1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Parser x -> Int
forall a. Parser a -> Int
numOptPs Parser x
p2
numOptPs (AltP  Parser a
p1  Parser a
p2) = Parser a -> Int
forall a. Parser a -> Int
numOptPs Parser a
p1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Parser a -> Int
forall a. Parser a -> Int
numOptPs Parser a
p2
numOptPs (BindP Parser x
p1 x -> Parser a
_p2) = Parser x -> Int
forall a. Parser a -> Int
numOptPs Parser x
p1

-- | The command line parser for the test suite, alongside any related
-- warnings.
--
-- @since 1.3
suiteOptionParser :: [Ingredient] -> TestTree -> ([String], Parser OptionSet)
suiteOptionParser :: [Ingredient] -> TestTree -> ([String], Parser OptionSet)
suiteOptionParser [Ingredient]
ins TestTree
tree = [OptionDescription] -> ([String], Parser OptionSet)
optionParser ([OptionDescription] -> ([String], Parser OptionSet))
-> [OptionDescription] -> ([String], Parser OptionSet)
forall a b. (a -> b) -> a -> b
$ [Ingredient] -> TestTree -> [OptionDescription]
suiteOptions [Ingredient]
ins TestTree
tree

-- | Parse the command-line and environment options passed to tasty.
--
-- Useful if you need to get the options before 'defaultMain' is called.
--
-- Once within the test tree, 'askOption' should be used instead.
--
-- The arguments to this function should be the same as for
-- 'defaultMainWithIngredients'. If you don't use any custom ingredients,
-- pass 'defaultIngredients'.
parseOptions :: [Ingredient] -> TestTree -> IO OptionSet
parseOptions :: [Ingredient] -> TestTree -> IO OptionSet
parseOptions [Ingredient]
ins TestTree
tree = do
  let ([String]
warnings, Parser OptionSet
parser) = [Ingredient] -> TestTree -> ([String], Parser OptionSet)
suiteOptionParser [Ingredient]
ins TestTree
tree
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
stderr) [String]
warnings
  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
<*> Parser OptionSet
parser)
    ( 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 String
"Mmm... tasty test suite"
    )
  OptionSet
envOpts <- [Ingredient] -> TestTree -> IO OptionSet
suiteEnvOptions [Ingredient]
ins TestTree
tree
  OptionSet -> IO OptionSet
forall (m :: * -> *) a. Monad m => a -> m a
return (OptionSet -> IO OptionSet) -> OptionSet -> IO OptionSet
forall a b. (a -> b) -> a -> b
$ OptionSet
envOpts OptionSet -> OptionSet -> OptionSet
forall a. Semigroup a => a -> a -> a
<> OptionSet
cmdlineOpts

-- | Parse the command line arguments and run the tests using the provided
-- ingredient list.
--
-- When the tests finish, this function calls 'exitWith' with the exit code
-- that indicates whether any tests have failed. See 'defaultMain' for
-- details.
defaultMainWithIngredients :: [Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients :: [Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients [Ingredient]
ins TestTree
testTree = do
  IO ()
installSignalHandlers
  OptionSet
opts <- [Ingredient] -> TestTree -> IO OptionSet
parseOptions [Ingredient]
ins TestTree
testTree

  case [Ingredient] -> OptionSet -> TestTree -> Maybe (IO Bool)
tryIngredients [Ingredient]
ins OptionSet
opts TestTree
testTree of
    Maybe (IO Bool)
Nothing -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr
        String
"No ingredients agreed to run. Something is wrong either with your ingredient set or the options."
      IO ()
forall a. IO a
exitFailure
    Just 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