{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Hedgehog.Internal.Config (
    UseColor(..)
  , resolveColor

  , Seed(..)
  , resolveSeed

  , Verbosity(..)
  , resolveVerbosity

  , WorkerCount(..)
  , resolveWorkers

  , Skip(..)
  , resolveSkip

  , detectMark
  , detectColor
  , detectSeed
  , detectVerbosity
  , detectWorkers
  , detectSkip
  ) where

import           Control.Monad.IO.Class (MonadIO(..))

import qualified Data.Text as Text

import qualified GHC.Conc as Conc

import           Hedgehog.Internal.Seed (Seed(..))
import qualified Hedgehog.Internal.Seed as Seed
import           Hedgehog.Internal.Property (Skip(..), skipDecompress)

import           Language.Haskell.TH.Syntax (Lift)

import           System.Console.ANSI (hSupportsANSI)
import           System.Environment (lookupEnv)
import           System.IO (stdout)

import           Text.Read (readMaybe)


-- | Whether to render output using ANSI colors or not.
--
data UseColor =
    DisableColor
    -- ^ Disable ANSI colors in report output.
  | EnableColor
    -- ^ Enable ANSI colors in report output.
    deriving (UseColor -> UseColor -> Bool
(UseColor -> UseColor -> Bool)
-> (UseColor -> UseColor -> Bool) -> Eq UseColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UseColor -> UseColor -> Bool
== :: UseColor -> UseColor -> Bool
$c/= :: UseColor -> UseColor -> Bool
/= :: UseColor -> UseColor -> Bool
Eq, Eq UseColor
Eq UseColor =>
(UseColor -> UseColor -> Ordering)
-> (UseColor -> UseColor -> Bool)
-> (UseColor -> UseColor -> Bool)
-> (UseColor -> UseColor -> Bool)
-> (UseColor -> UseColor -> Bool)
-> (UseColor -> UseColor -> UseColor)
-> (UseColor -> UseColor -> UseColor)
-> Ord UseColor
UseColor -> UseColor -> Bool
UseColor -> UseColor -> Ordering
UseColor -> UseColor -> UseColor
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UseColor -> UseColor -> Ordering
compare :: UseColor -> UseColor -> Ordering
$c< :: UseColor -> UseColor -> Bool
< :: UseColor -> UseColor -> Bool
$c<= :: UseColor -> UseColor -> Bool
<= :: UseColor -> UseColor -> Bool
$c> :: UseColor -> UseColor -> Bool
> :: UseColor -> UseColor -> Bool
$c>= :: UseColor -> UseColor -> Bool
>= :: UseColor -> UseColor -> Bool
$cmax :: UseColor -> UseColor -> UseColor
max :: UseColor -> UseColor -> UseColor
$cmin :: UseColor -> UseColor -> UseColor
min :: UseColor -> UseColor -> UseColor
Ord, Int -> UseColor -> ShowS
[UseColor] -> ShowS
UseColor -> String
(Int -> UseColor -> ShowS)
-> (UseColor -> String) -> ([UseColor] -> ShowS) -> Show UseColor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UseColor -> ShowS
showsPrec :: Int -> UseColor -> ShowS
$cshow :: UseColor -> String
show :: UseColor -> String
$cshowList :: [UseColor] -> ShowS
showList :: [UseColor] -> ShowS
Show, (forall (m :: * -> *). Quote m => UseColor -> m Exp)
-> (forall (m :: * -> *). Quote m => UseColor -> Code m UseColor)
-> Lift UseColor
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => UseColor -> m Exp
forall (m :: * -> *). Quote m => UseColor -> Code m UseColor
$clift :: forall (m :: * -> *). Quote m => UseColor -> m Exp
lift :: forall (m :: * -> *). Quote m => UseColor -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => UseColor -> Code m UseColor
liftTyped :: forall (m :: * -> *). Quote m => UseColor -> Code m UseColor
Lift)

-- | How verbose should the report output be.
--
data Verbosity =
    Quiet
    -- ^ Only display the summary of the test run.
  | Normal
    -- ^ Display each property as it is running, as well as the summary.
    deriving (Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
/= :: Verbosity -> Verbosity -> Bool
Eq, Eq Verbosity
Eq Verbosity =>
(Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Verbosity -> Verbosity -> Ordering
compare :: Verbosity -> Verbosity -> Ordering
$c< :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
>= :: Verbosity -> Verbosity -> Bool
$cmax :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
min :: Verbosity -> Verbosity -> Verbosity
Ord, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
(Int -> Verbosity -> ShowS)
-> (Verbosity -> String)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Verbosity -> ShowS
showsPrec :: Int -> Verbosity -> ShowS
$cshow :: Verbosity -> String
show :: Verbosity -> String
$cshowList :: [Verbosity] -> ShowS
showList :: [Verbosity] -> ShowS
Show, (forall (m :: * -> *). Quote m => Verbosity -> m Exp)
-> (forall (m :: * -> *). Quote m => Verbosity -> Code m Verbosity)
-> Lift Verbosity
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Verbosity -> m Exp
forall (m :: * -> *). Quote m => Verbosity -> Code m Verbosity
$clift :: forall (m :: * -> *). Quote m => Verbosity -> m Exp
lift :: forall (m :: * -> *). Quote m => Verbosity -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Verbosity -> Code m Verbosity
liftTyped :: forall (m :: * -> *). Quote m => Verbosity -> Code m Verbosity
Lift)

-- | The number of workers to use when running properties in parallel.
--
newtype WorkerCount =
  WorkerCount Int
  deriving (WorkerCount -> WorkerCount -> Bool
(WorkerCount -> WorkerCount -> Bool)
-> (WorkerCount -> WorkerCount -> Bool) -> Eq WorkerCount
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WorkerCount -> WorkerCount -> Bool
== :: WorkerCount -> WorkerCount -> Bool
$c/= :: WorkerCount -> WorkerCount -> Bool
/= :: WorkerCount -> WorkerCount -> Bool
Eq, Eq WorkerCount
Eq WorkerCount =>
(WorkerCount -> WorkerCount -> Ordering)
-> (WorkerCount -> WorkerCount -> Bool)
-> (WorkerCount -> WorkerCount -> Bool)
-> (WorkerCount -> WorkerCount -> Bool)
-> (WorkerCount -> WorkerCount -> Bool)
-> (WorkerCount -> WorkerCount -> WorkerCount)
-> (WorkerCount -> WorkerCount -> WorkerCount)
-> Ord WorkerCount
WorkerCount -> WorkerCount -> Bool
WorkerCount -> WorkerCount -> Ordering
WorkerCount -> WorkerCount -> WorkerCount
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: WorkerCount -> WorkerCount -> Ordering
compare :: WorkerCount -> WorkerCount -> Ordering
$c< :: WorkerCount -> WorkerCount -> Bool
< :: WorkerCount -> WorkerCount -> Bool
$c<= :: WorkerCount -> WorkerCount -> Bool
<= :: WorkerCount -> WorkerCount -> Bool
$c> :: WorkerCount -> WorkerCount -> Bool
> :: WorkerCount -> WorkerCount -> Bool
$c>= :: WorkerCount -> WorkerCount -> Bool
>= :: WorkerCount -> WorkerCount -> Bool
$cmax :: WorkerCount -> WorkerCount -> WorkerCount
max :: WorkerCount -> WorkerCount -> WorkerCount
$cmin :: WorkerCount -> WorkerCount -> WorkerCount
min :: WorkerCount -> WorkerCount -> WorkerCount
Ord, Int -> WorkerCount -> ShowS
[WorkerCount] -> ShowS
WorkerCount -> String
(Int -> WorkerCount -> ShowS)
-> (WorkerCount -> String)
-> ([WorkerCount] -> ShowS)
-> Show WorkerCount
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WorkerCount -> ShowS
showsPrec :: Int -> WorkerCount -> ShowS
$cshow :: WorkerCount -> String
show :: WorkerCount -> String
$cshowList :: [WorkerCount] -> ShowS
showList :: [WorkerCount] -> ShowS
Show, Integer -> WorkerCount
WorkerCount -> WorkerCount
WorkerCount -> WorkerCount -> WorkerCount
(WorkerCount -> WorkerCount -> WorkerCount)
-> (WorkerCount -> WorkerCount -> WorkerCount)
-> (WorkerCount -> WorkerCount -> WorkerCount)
-> (WorkerCount -> WorkerCount)
-> (WorkerCount -> WorkerCount)
-> (WorkerCount -> WorkerCount)
-> (Integer -> WorkerCount)
-> Num WorkerCount
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: WorkerCount -> WorkerCount -> WorkerCount
+ :: WorkerCount -> WorkerCount -> WorkerCount
$c- :: WorkerCount -> WorkerCount -> WorkerCount
- :: WorkerCount -> WorkerCount -> WorkerCount
$c* :: WorkerCount -> WorkerCount -> WorkerCount
* :: WorkerCount -> WorkerCount -> WorkerCount
$cnegate :: WorkerCount -> WorkerCount
negate :: WorkerCount -> WorkerCount
$cabs :: WorkerCount -> WorkerCount
abs :: WorkerCount -> WorkerCount
$csignum :: WorkerCount -> WorkerCount
signum :: WorkerCount -> WorkerCount
$cfromInteger :: Integer -> WorkerCount
fromInteger :: Integer -> WorkerCount
Num, Int -> WorkerCount
WorkerCount -> Int
WorkerCount -> [WorkerCount]
WorkerCount -> WorkerCount
WorkerCount -> WorkerCount -> [WorkerCount]
WorkerCount -> WorkerCount -> WorkerCount -> [WorkerCount]
(WorkerCount -> WorkerCount)
-> (WorkerCount -> WorkerCount)
-> (Int -> WorkerCount)
-> (WorkerCount -> Int)
-> (WorkerCount -> [WorkerCount])
-> (WorkerCount -> WorkerCount -> [WorkerCount])
-> (WorkerCount -> WorkerCount -> [WorkerCount])
-> (WorkerCount -> WorkerCount -> WorkerCount -> [WorkerCount])
-> Enum WorkerCount
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: WorkerCount -> WorkerCount
succ :: WorkerCount -> WorkerCount
$cpred :: WorkerCount -> WorkerCount
pred :: WorkerCount -> WorkerCount
$ctoEnum :: Int -> WorkerCount
toEnum :: Int -> WorkerCount
$cfromEnum :: WorkerCount -> Int
fromEnum :: WorkerCount -> Int
$cenumFrom :: WorkerCount -> [WorkerCount]
enumFrom :: WorkerCount -> [WorkerCount]
$cenumFromThen :: WorkerCount -> WorkerCount -> [WorkerCount]
enumFromThen :: WorkerCount -> WorkerCount -> [WorkerCount]
$cenumFromTo :: WorkerCount -> WorkerCount -> [WorkerCount]
enumFromTo :: WorkerCount -> WorkerCount -> [WorkerCount]
$cenumFromThenTo :: WorkerCount -> WorkerCount -> WorkerCount -> [WorkerCount]
enumFromThenTo :: WorkerCount -> WorkerCount -> WorkerCount -> [WorkerCount]
Enum, Num WorkerCount
Ord WorkerCount
(Num WorkerCount, Ord WorkerCount) =>
(WorkerCount -> Rational) -> Real WorkerCount
WorkerCount -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: WorkerCount -> Rational
toRational :: WorkerCount -> Rational
Real, Enum WorkerCount
Real WorkerCount
(Real WorkerCount, Enum WorkerCount) =>
(WorkerCount -> WorkerCount -> WorkerCount)
-> (WorkerCount -> WorkerCount -> WorkerCount)
-> (WorkerCount -> WorkerCount -> WorkerCount)
-> (WorkerCount -> WorkerCount -> WorkerCount)
-> (WorkerCount -> WorkerCount -> (WorkerCount, WorkerCount))
-> (WorkerCount -> WorkerCount -> (WorkerCount, WorkerCount))
-> (WorkerCount -> Integer)
-> Integral WorkerCount
WorkerCount -> Integer
WorkerCount -> WorkerCount -> (WorkerCount, WorkerCount)
WorkerCount -> WorkerCount -> WorkerCount
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
$cquot :: WorkerCount -> WorkerCount -> WorkerCount
quot :: WorkerCount -> WorkerCount -> WorkerCount
$crem :: WorkerCount -> WorkerCount -> WorkerCount
rem :: WorkerCount -> WorkerCount -> WorkerCount
$cdiv :: WorkerCount -> WorkerCount -> WorkerCount
div :: WorkerCount -> WorkerCount -> WorkerCount
$cmod :: WorkerCount -> WorkerCount -> WorkerCount
mod :: WorkerCount -> WorkerCount -> WorkerCount
$cquotRem :: WorkerCount -> WorkerCount -> (WorkerCount, WorkerCount)
quotRem :: WorkerCount -> WorkerCount -> (WorkerCount, WorkerCount)
$cdivMod :: WorkerCount -> WorkerCount -> (WorkerCount, WorkerCount)
divMod :: WorkerCount -> WorkerCount -> (WorkerCount, WorkerCount)
$ctoInteger :: WorkerCount -> Integer
toInteger :: WorkerCount -> Integer
Integral, (forall (m :: * -> *). Quote m => WorkerCount -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    WorkerCount -> Code m WorkerCount)
-> Lift WorkerCount
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => WorkerCount -> m Exp
forall (m :: * -> *). Quote m => WorkerCount -> Code m WorkerCount
$clift :: forall (m :: * -> *). Quote m => WorkerCount -> m Exp
lift :: forall (m :: * -> *). Quote m => WorkerCount -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => WorkerCount -> Code m WorkerCount
liftTyped :: forall (m :: * -> *). Quote m => WorkerCount -> Code m WorkerCount
Lift)

detectMark :: MonadIO m => m Bool
detectMark :: forall (m :: * -> *). MonadIO m => m Bool
detectMark = do
  Maybe String
user <- IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> m (Maybe String))
-> IO (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
"USER"
  Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Maybe String
user Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
"mth"

lookupBool :: MonadIO m => String -> m (Maybe Bool)
lookupBool :: forall (m :: * -> *). MonadIO m => String -> m (Maybe Bool)
lookupBool String
key =
  IO (Maybe Bool) -> m (Maybe Bool)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Bool) -> m (Maybe Bool))
-> IO (Maybe Bool) -> m (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ do
    Maybe String
menv <- String -> IO (Maybe String)
lookupEnv String
key
    case Maybe String
menv of
      Just String
"0" ->
        Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Bool -> IO (Maybe Bool)) -> Maybe Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
      Just String
"no" ->
        Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Bool -> IO (Maybe Bool)) -> Maybe Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
      Just String
"false" ->
        Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Bool -> IO (Maybe Bool)) -> Maybe Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False

      Just String
"1" ->
        Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Bool -> IO (Maybe Bool)) -> Maybe Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
      Just String
"yes" ->
        Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Bool -> IO (Maybe Bool)) -> Maybe Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
      Just String
"true" ->
        Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Bool -> IO (Maybe Bool)) -> Maybe Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True

      Maybe String
_ ->
        Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bool
forall a. Maybe a
Nothing

detectColor :: MonadIO m => m UseColor
detectColor :: forall (m :: * -> *). MonadIO m => m UseColor
detectColor =
  IO UseColor -> m UseColor
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UseColor -> m UseColor) -> IO UseColor -> m UseColor
forall a b. (a -> b) -> a -> b
$ do
    Maybe Bool
ok <- String -> IO (Maybe Bool)
forall (m :: * -> *). MonadIO m => String -> m (Maybe Bool)
lookupBool String
"HEDGEHOG_COLOR"
    case Maybe Bool
ok of
      Just Bool
False ->
        UseColor -> IO UseColor
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseColor
DisableColor

      Just Bool
True ->
        UseColor -> IO UseColor
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseColor
EnableColor

      Maybe Bool
Nothing -> do
        Bool
mth <- IO Bool
forall (m :: * -> *). MonadIO m => m Bool
detectMark
        if Bool
mth then
          UseColor -> IO UseColor
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseColor
DisableColor -- avoid getting fired :)
        else do
          Bool
enable <- Handle -> IO Bool
hSupportsANSI Handle
stdout
          if Bool
enable then
            UseColor -> IO UseColor
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseColor
EnableColor
          else
            UseColor -> IO UseColor
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseColor
DisableColor

splitOn :: String -> String -> [String]
splitOn :: String -> String -> [String]
splitOn String
needle String
haystack =
  (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
Text.unpack ([Text] -> [String]) -> [Text] -> [String]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn (String -> Text
Text.pack String
needle) (String -> Text
Text.pack String
haystack)

parseSeed :: String -> Maybe Seed
parseSeed :: String -> Maybe Seed
parseSeed String
env =
  case String -> String -> [String]
splitOn String
" " String
env of
    [String
value, String
gamma] ->
      Word64 -> Word64 -> Seed
Seed (Word64 -> Word64 -> Seed)
-> Maybe Word64 -> Maybe (Word64 -> Seed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Word64
forall a. Read a => String -> Maybe a
readMaybe String
value Maybe (Word64 -> Seed) -> Maybe Word64 -> Maybe Seed
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe Word64
forall a. Read a => String -> Maybe a
readMaybe String
gamma
    [String]
_ ->
      Maybe Seed
forall a. Maybe a
Nothing

detectSeed :: MonadIO m => m Seed
detectSeed :: forall (m :: * -> *). MonadIO m => m Seed
detectSeed =
  IO Seed -> m Seed
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Seed -> m Seed) -> IO Seed -> m Seed
forall a b. (a -> b) -> a -> b
$ do
    Maybe String
menv <- String -> IO (Maybe String)
lookupEnv String
"HEDGEHOG_SEED"
    case String -> Maybe Seed
parseSeed (String -> Maybe Seed) -> Maybe String -> Maybe Seed
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
menv of
      Maybe Seed
Nothing ->
        IO Seed
forall (m :: * -> *). MonadIO m => m Seed
Seed.random
      Just Seed
seed ->
        Seed -> IO Seed
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seed
seed

detectVerbosity :: MonadIO m => m Verbosity
detectVerbosity :: forall (m :: * -> *). MonadIO m => m Verbosity
detectVerbosity =
  IO Verbosity -> m Verbosity
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Verbosity -> m Verbosity) -> IO Verbosity -> m Verbosity
forall a b. (a -> b) -> a -> b
$ do
    Maybe Int
menv <- (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> Maybe String -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe String -> Maybe Int) -> IO (Maybe String) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"HEDGEHOG_VERBOSITY"
    case Maybe Int
menv of
      Just (Int
0 :: Int) ->
        Verbosity -> IO Verbosity
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
Quiet

      Just (Int
1 :: Int) ->
        Verbosity -> IO Verbosity
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
Normal

      Maybe Int
_ -> do
        Bool
mth <- IO Bool
forall (m :: * -> *). MonadIO m => m Bool
detectMark
        if Bool
mth then
          Verbosity -> IO Verbosity
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
Quiet
        else
          Verbosity -> IO Verbosity
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
Normal

detectWorkers :: MonadIO m => m WorkerCount
detectWorkers :: forall (m :: * -> *). MonadIO m => m WorkerCount
detectWorkers = do
  IO WorkerCount -> m WorkerCount
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WorkerCount -> m WorkerCount)
-> IO WorkerCount -> m WorkerCount
forall a b. (a -> b) -> a -> b
$ do
    Maybe Int
menv <- (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> Maybe String -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe String -> Maybe Int) -> IO (Maybe String) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"HEDGEHOG_WORKERS"
    case Maybe Int
menv of
      Maybe Int
Nothing ->
        Int -> WorkerCount
WorkerCount (Int -> WorkerCount) -> IO Int -> IO WorkerCount
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
Conc.getNumProcessors
      Just Int
env ->
        WorkerCount -> IO WorkerCount
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WorkerCount -> IO WorkerCount) -> WorkerCount -> IO WorkerCount
forall a b. (a -> b) -> a -> b
$ Int -> WorkerCount
WorkerCount Int
env

detectSkip :: MonadIO m => m Skip
detectSkip :: forall (m :: * -> *). MonadIO m => m Skip
detectSkip =
  IO Skip -> m Skip
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Skip -> m Skip) -> IO Skip -> m Skip
forall a b. (a -> b) -> a -> b
$ do
    Maybe String
menv <- String -> IO (Maybe String)
lookupEnv String
"HEDGEHOG_SKIP"
    case Maybe String
menv of
      Maybe String
Nothing ->
        Skip -> IO Skip
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Skip
SkipNothing
      Just String
env ->
        case String -> Maybe Skip
skipDecompress String
env of
          Maybe Skip
Nothing ->
            -- It's clearer for the user if we error out here, rather than
            -- silently defaulting to SkipNothing.
            String -> IO Skip
forall a. HasCallStack => String -> a
error String
"HEDGEHOG_SKIP is not a valid Skip."
          Just Skip
skip ->
            Skip -> IO Skip
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Skip
skip

resolveColor :: MonadIO m => Maybe UseColor -> m UseColor
resolveColor :: forall (m :: * -> *). MonadIO m => Maybe UseColor -> m UseColor
resolveColor = \case
  Maybe UseColor
Nothing ->
    m UseColor
forall (m :: * -> *). MonadIO m => m UseColor
detectColor
  Just UseColor
x ->
    UseColor -> m UseColor
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseColor
x

resolveSeed :: MonadIO m => Maybe Seed -> m Seed
resolveSeed :: forall (m :: * -> *). MonadIO m => Maybe Seed -> m Seed
resolveSeed = \case
  Maybe Seed
Nothing ->
    m Seed
forall (m :: * -> *). MonadIO m => m Seed
detectSeed
  Just Seed
x ->
    Seed -> m Seed
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seed
x

resolveVerbosity :: MonadIO m => Maybe Verbosity -> m Verbosity
resolveVerbosity :: forall (m :: * -> *). MonadIO m => Maybe Verbosity -> m Verbosity
resolveVerbosity = \case
  Maybe Verbosity
Nothing ->
    m Verbosity
forall (m :: * -> *). MonadIO m => m Verbosity
detectVerbosity
  Just Verbosity
x ->
    Verbosity -> m Verbosity
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
x

resolveWorkers :: MonadIO m => Maybe WorkerCount -> m WorkerCount
resolveWorkers :: forall (m :: * -> *).
MonadIO m =>
Maybe WorkerCount -> m WorkerCount
resolveWorkers = \case
  Maybe WorkerCount
Nothing ->
    m WorkerCount
forall (m :: * -> *). MonadIO m => m WorkerCount
detectWorkers
  Just WorkerCount
x ->
    WorkerCount -> m WorkerCount
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WorkerCount
x

resolveSkip :: MonadIO m => Maybe Skip -> m Skip
resolveSkip :: forall (m :: * -> *). MonadIO m => Maybe Skip -> m Skip
resolveSkip = \case
  Maybe Skip
Nothing ->
    m Skip
forall (m :: * -> *). MonadIO m => m Skip
detectSkip
  Just Skip
x ->
    Skip -> m Skip
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Skip
x