-- | 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) =
    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 = forall (f :: * -> *) a. Ap f a -> f a
getApp forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall {k} (s :: k) a (proxy :: k -> *). Tagged s a -> proxy s -> a
proxy forall v. IsOption v => Tagged v String
optionName Proxy v
px
        envName :: String
envName = (String
"TASTY_" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map String
name forall a b. (a -> b) -> a -> b
$ \Char
c ->
          if Char
c forall a. Eq a => a -> a -> Bool
== Char
'-'
            then Char
'_'
            else Char -> Char
toUpper Char
c
      Maybe String
mbValueStr <- forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
myLookupEnv String
envName
      forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Maybe String
mbValueStr forall a b. (a -> b) -> a -> b
$ \String
valueStr ->
        let
          mbValue :: Maybe v
          mbValue :: Maybe v
mbValue = forall v. IsOption v => String -> Maybe v
parseValue String
valueStr

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

        in forall (f :: * -> *) a. f a -> Ap f a
Ap forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. IO a
err (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO String
getEnv String
name) :: IO (Either IOException String))