    -- | Get options from the environment
    {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
    module Test.Tasty.Options.Env (getEnvOptions, suiteEnvOptions) where

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

    import System.Environment
    import Data.Foldable
    import Data.Tagged
    import Data.Proxy
    import Data.Char
    import Data.Typeable
    import Control.Exception
    import Control.Applicative
    import Prelude  -- Silence AMP and FTP import warnings
    import Text.Printf

    data EnvOptionException
      = BadOption
          String -- option name
          String -- variable name
          String -- value
      deriving (Typeable)

    instance Show EnvOptionException where
      show :: EnvOptionException -> String
    show (BadOption String
    optName String
    varName String
    value) =
        String -> String -> String -> ShowS
    forall r. PrintfType r => String -> r
    printf
          String
    "Bad environment variable %s='%s' (parsed as option %s)"
            String
    varName String
    value String
    optName

    instance Exception EnvOptionException

    -- | Search the environment for given options
    getEnvOptions :: [OptionDescription] -> IO OptionSet
    getEnvOptions :: [OptionDescription] -> IO OptionSet
    getEnvOptions = Ap IO OptionSet -> IO OptionSet
    forall (f :: * -> *) a. Ap f a -> f a
    getApp (Ap IO OptionSet -> IO OptionSet)
    -> ([OptionDescription] -> Ap IO OptionSet)
    -> [OptionDescription]
    -> IO OptionSet
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (OptionDescription -> Ap IO OptionSet)
    -> [OptionDescription] -> Ap IO OptionSet
    forall m a. Monoid m => (a -> m) -> [a] -> m
    forall (t :: * -> *) m a.
    (Foldable t, Monoid m) =>
    (a -> m) -> t a -> m
    foldMap OptionDescription -> Ap IO OptionSet
    lookupOpt
      where
        lookupOpt :: OptionDescription -> Ap IO OptionSet
        lookupOpt :: OptionDescription -> Ap IO OptionSet
    lookupOpt (Option (Proxy v
    px :: Proxy v)) = do
          let
            name :: String
    name = Tagged v String -> Proxy v -> String
    forall {k} (s :: k) a (proxy :: k -> *). Tagged s a -> proxy s -> a
    proxy Tagged v String
    forall v. IsOption v => Tagged v String
    optionName Proxy v
    px
            envName :: String
    envName = (String
    "TASTY_" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++) ShowS -> ((Char -> Char) -> String) -> (Char -> Char) -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((Char -> Char) -> ShowS) -> String -> (Char -> Char) -> String
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (Char -> Char) -> ShowS
    forall a b. (a -> b) -> [a] -> [b]
    map String
    name ((Char -> Char) -> String) -> (Char -> Char) -> String
    forall a b. (a -> b) -> a -> b
    $ \Char
    c ->
              if Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '-'
                then Char
    '_'
                else Char -> Char
    toUpper Char
    c
          mbValueStr <- IO (Maybe String) -> Ap IO (Maybe String)
    forall (f :: * -> *) a. f a -> Ap f a
    Ap (IO (Maybe String) -> Ap IO (Maybe String))
    -> IO (Maybe String) -> Ap IO (Maybe String)
    forall a b. (a -> b) -> a -> b
    $ String -> IO (Maybe String)
    myLookupEnv String
    envName
          flip foldMap mbValueStr $ \String
    valueStr ->
            let
              mbValue :: Maybe v
              mbValue :: Maybe v
    mbValue = String -> Maybe v
    forall v. IsOption v => String -> Maybe v
    parseValue String
    valueStr

              err :: IO a
    err = EnvOptionException -> IO a
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO (EnvOptionException -> IO a) -> EnvOptionException -> IO a
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String -> EnvOptionException
    BadOption String
    name String
    envName String
    valueStr

            in IO OptionSet -> Ap IO OptionSet
    forall (f :: * -> *) a. f a -> Ap f a
    Ap (IO OptionSet -> Ap IO OptionSet)
    -> IO OptionSet -> Ap IO OptionSet
    forall a b. (a -> b) -> a -> b
    $ IO OptionSet -> (v -> IO OptionSet) -> Maybe v -> IO OptionSet
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe IO OptionSet
    forall {a}. IO a
    err (OptionSet -> IO OptionSet
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (OptionSet -> IO OptionSet)
    -> (v -> OptionSet) -> v -> IO OptionSet
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . v -> OptionSet
    forall v. IsOption v => v -> OptionSet
    singleOption) Maybe v
    mbValue

    -- | Search the environment for all options relevant for this suite
    suiteEnvOptions :: [Ingredient] -> TestTree -> IO OptionSet
    suiteEnvOptions :: [Ingredient] -> TestTree -> IO OptionSet
    suiteEnvOptions [Ingredient]
    ins TestTree
    tree = [OptionDescription] -> IO OptionSet
    getEnvOptions ([OptionDescription] -> IO OptionSet)
    -> [OptionDescription] -> IO OptionSet
    forall a b. (a -> b) -> a -> b
    $ [Ingredient] -> TestTree -> [OptionDescription]
    suiteOptions [Ingredient]
    ins TestTree
    tree

    -- note: switch to lookupEnv once we no longer support 7.4
    myLookupEnv :: String -> IO (Maybe String)
    myLookupEnv :: String -> IO (Maybe String)
    myLookupEnv String
    name = (IOException -> Maybe String)
    -> (String -> Maybe String)
    -> Either IOException String
    -> Maybe String
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either (Maybe String -> IOException -> Maybe String
    forall a b. a -> b -> a
    const Maybe String
    forall a. Maybe a
    Nothing) String -> Maybe String
    forall a. a -> Maybe a
    Just (Either IOException String -> Maybe String)
    -> IO (Either IOException String) -> IO (Maybe String)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (IO String -> IO (Either IOException String)
    forall e a. Exception e => IO a -> IO (Either e a)
    try (String -> IO String
    getEnv String
    name) :: IO (Either IOException String))