-- | Get options from the environment
{-# LANGUAGE 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.Tagged
import Data.Proxy
import Data.Char
import Control.Exception
import Text.Printf

data EnvOptionException
  = BadOption
      String -- option name
      String -- variable name
      String -- value

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))