Env.hs

-- | 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 (BadOption optName varName value) =
    printf
      "Bad environment variable %s='%s' (parsed as option %s)"
        varName value optName

instance Exception EnvOptionException

-- | Search the environment for given options
getEnvOptions :: [OptionDescription] -> IO OptionSet
getEnvOptions = getApp . foldMap lookupOpt
  where
    lookupOpt :: OptionDescription -> Ap IO OptionSet
    lookupOpt (Option (px :: Proxy v)) = do
      let
        name = proxy optionName px
        envName = ("TASTY_" ++) . flip map name $ \c ->
          if c == '-'
            then '_'
            else toUpper c
      mbValueStr <- Ap $ myLookupEnv envName
      flip foldMap mbValueStr $ \valueStr ->
        let
          mbValue :: Maybe v
          mbValue = parseValue valueStr

          err = throwIO $ BadOption name envName valueStr

        in Ap $ maybe err (return . singleOption) mbValue

-- | Search the environment for all options relevant for this suite
suiteEnvOptions :: [Ingredient] -> TestTree -> IO OptionSet
suiteEnvOptions ins tree = getEnvOptions $ suiteOptions ins tree

-- note: switch to lookupEnv once we no longer support 7.4
myLookupEnv :: String -> IO (Maybe String)
myLookupEnv name = either (const Nothing) Just <$> (try (getEnv name) :: IO (Either IOException String))