-- | 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 (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
      Maybe String
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
      ((String -> Ap IO OptionSet) -> Maybe String -> Ap IO OptionSet)
-> Maybe String -> (String -> Ap IO OptionSet) -> Ap IO OptionSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> Ap IO OptionSet) -> Maybe String -> Ap IO OptionSet
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Maybe String
mbValueStr ((String -> Ap IO OptionSet) -> Ap IO OptionSet)
-> (String -> Ap IO OptionSet) -> Ap IO OptionSet
forall a b. (a -> b) -> a -> b
$ \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. 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 (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))