{-# 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)
data UseColor =
DisableColor
| EnableColor
deriving (UseColor -> UseColor -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UseColor -> UseColor -> Bool
$c/= :: UseColor -> UseColor -> Bool
== :: UseColor -> UseColor -> Bool
$c== :: UseColor -> UseColor -> Bool
Eq, Eq 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
min :: UseColor -> UseColor -> UseColor
$cmin :: UseColor -> UseColor -> UseColor
max :: UseColor -> UseColor -> UseColor
$cmax :: UseColor -> UseColor -> UseColor
>= :: UseColor -> UseColor -> Bool
$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
compare :: UseColor -> UseColor -> Ordering
$ccompare :: UseColor -> UseColor -> Ordering
Ord, Int -> UseColor -> ShowS
[UseColor] -> ShowS
UseColor -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UseColor] -> ShowS
$cshowList :: [UseColor] -> ShowS
show :: UseColor -> String
$cshow :: UseColor -> String
showsPrec :: Int -> UseColor -> ShowS
$cshowsPrec :: Int -> UseColor -> ShowS
Show, 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
liftTyped :: forall (m :: * -> *). Quote m => UseColor -> Code m UseColor
$cliftTyped :: forall (m :: * -> *). Quote m => UseColor -> Code m UseColor
lift :: forall (m :: * -> *). Quote m => UseColor -> m Exp
$clift :: forall (m :: * -> *). Quote m => UseColor -> m Exp
Lift)
data Verbosity =
Quiet
| Normal
deriving (Verbosity -> Verbosity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Eq 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
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$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
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
Ord, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show, 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
liftTyped :: forall (m :: * -> *). Quote m => Verbosity -> Code m Verbosity
$cliftTyped :: forall (m :: * -> *). Quote m => Verbosity -> Code m Verbosity
lift :: forall (m :: * -> *). Quote m => Verbosity -> m Exp
$clift :: forall (m :: * -> *). Quote m => Verbosity -> m Exp
Lift)
newtype WorkerCount =
WorkerCount Int
deriving (WorkerCount -> WorkerCount -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WorkerCount -> WorkerCount -> Bool
$c/= :: WorkerCount -> WorkerCount -> Bool
== :: WorkerCount -> WorkerCount -> Bool
$c== :: WorkerCount -> WorkerCount -> Bool
Eq, Eq 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
min :: WorkerCount -> WorkerCount -> WorkerCount
$cmin :: WorkerCount -> WorkerCount -> WorkerCount
max :: WorkerCount -> WorkerCount -> WorkerCount
$cmax :: WorkerCount -> WorkerCount -> WorkerCount
>= :: WorkerCount -> WorkerCount -> Bool
$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
compare :: WorkerCount -> WorkerCount -> Ordering
$ccompare :: WorkerCount -> WorkerCount -> Ordering
Ord, Int -> WorkerCount -> ShowS
[WorkerCount] -> ShowS
WorkerCount -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WorkerCount] -> ShowS
$cshowList :: [WorkerCount] -> ShowS
show :: WorkerCount -> String
$cshow :: WorkerCount -> String
showsPrec :: Int -> WorkerCount -> ShowS
$cshowsPrec :: Int -> WorkerCount -> ShowS
Show, Integer -> WorkerCount
WorkerCount -> WorkerCount
WorkerCount -> WorkerCount -> WorkerCount
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> WorkerCount
$cfromInteger :: Integer -> WorkerCount
signum :: WorkerCount -> WorkerCount
$csignum :: WorkerCount -> WorkerCount
abs :: WorkerCount -> WorkerCount
$cabs :: WorkerCount -> WorkerCount
negate :: WorkerCount -> WorkerCount
$cnegate :: WorkerCount -> WorkerCount
* :: WorkerCount -> WorkerCount -> WorkerCount
$c* :: WorkerCount -> WorkerCount -> WorkerCount
- :: WorkerCount -> WorkerCount -> WorkerCount
$c- :: WorkerCount -> WorkerCount -> WorkerCount
+ :: WorkerCount -> WorkerCount -> WorkerCount
$c+ :: WorkerCount -> WorkerCount -> WorkerCount
Num, Int -> WorkerCount
WorkerCount -> Int
WorkerCount -> [WorkerCount]
WorkerCount -> WorkerCount
WorkerCount -> WorkerCount -> [WorkerCount]
WorkerCount -> WorkerCount -> WorkerCount -> [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
enumFromThenTo :: WorkerCount -> WorkerCount -> WorkerCount -> [WorkerCount]
$cenumFromThenTo :: WorkerCount -> WorkerCount -> WorkerCount -> [WorkerCount]
enumFromTo :: WorkerCount -> WorkerCount -> [WorkerCount]
$cenumFromTo :: WorkerCount -> WorkerCount -> [WorkerCount]
enumFromThen :: WorkerCount -> WorkerCount -> [WorkerCount]
$cenumFromThen :: WorkerCount -> WorkerCount -> [WorkerCount]
enumFrom :: WorkerCount -> [WorkerCount]
$cenumFrom :: WorkerCount -> [WorkerCount]
fromEnum :: WorkerCount -> Int
$cfromEnum :: WorkerCount -> Int
toEnum :: Int -> WorkerCount
$ctoEnum :: Int -> WorkerCount
pred :: WorkerCount -> WorkerCount
$cpred :: WorkerCount -> WorkerCount
succ :: WorkerCount -> WorkerCount
$csucc :: WorkerCount -> WorkerCount
Enum, Num WorkerCount
Ord WorkerCount
WorkerCount -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: WorkerCount -> Rational
$ctoRational :: WorkerCount -> Rational
Real, Enum WorkerCount
Real 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
toInteger :: WorkerCount -> Integer
$ctoInteger :: WorkerCount -> Integer
divMod :: WorkerCount -> WorkerCount -> (WorkerCount, WorkerCount)
$cdivMod :: WorkerCount -> WorkerCount -> (WorkerCount, WorkerCount)
quotRem :: WorkerCount -> WorkerCount -> (WorkerCount, WorkerCount)
$cquotRem :: WorkerCount -> WorkerCount -> (WorkerCount, WorkerCount)
mod :: WorkerCount -> WorkerCount -> WorkerCount
$cmod :: WorkerCount -> WorkerCount -> WorkerCount
div :: WorkerCount -> WorkerCount -> WorkerCount
$cdiv :: WorkerCount -> WorkerCount -> WorkerCount
rem :: WorkerCount -> WorkerCount -> WorkerCount
$crem :: WorkerCount -> WorkerCount -> WorkerCount
quot :: WorkerCount -> WorkerCount -> WorkerCount
$cquot :: WorkerCount -> WorkerCount -> WorkerCount
Integral, 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
liftTyped :: forall (m :: * -> *). Quote m => WorkerCount -> Code m WorkerCount
$cliftTyped :: forall (m :: * -> *). Quote m => WorkerCount -> Code m WorkerCount
lift :: forall (m :: * -> *). Quote m => WorkerCount -> m Exp
$clift :: forall (m :: * -> *). Quote m => WorkerCount -> m Exp
Lift)
detectMark :: MonadIO m => m Bool
detectMark :: forall (m :: * -> *). MonadIO m => m Bool
detectMark = do
Maybe String
user <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
"USER"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe String
user forall a. Eq a => a -> a -> Bool
== 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 =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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" ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
False
Just String
"no" ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
False
Just String
"false" ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
False
Just String
"1" ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
True
Just String
"yes" ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
True
Just String
"true" ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
True
Maybe String
_ ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
detectColor :: MonadIO m => m UseColor
detectColor :: forall (m :: * -> *). MonadIO m => m UseColor
detectColor =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Maybe Bool
ok <- forall (m :: * -> *). MonadIO m => String -> m (Maybe Bool)
lookupBool String
"HEDGEHOG_COLOR"
case Maybe Bool
ok of
Just Bool
False ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseColor
DisableColor
Just Bool
True ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseColor
EnableColor
Maybe Bool
Nothing -> do
Bool
mth <- forall (m :: * -> *). MonadIO m => m Bool
detectMark
if Bool
mth then
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseColor
DisableColor
else do
Bool
enable <- Handle -> IO Bool
hSupportsANSI Handle
stdout
if Bool
enable then
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseColor
EnableColor
else
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseColor
DisableColor
splitOn :: String -> String -> [String]
splitOn :: String -> String -> [String]
splitOn String
needle String
haystack =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
Text.unpack forall a b. (a -> b) -> a -> b
$ 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Read a => String -> Maybe a
readMaybe String
value forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Read a => String -> Maybe a
readMaybe String
gamma
[String]
_ ->
forall a. Maybe a
Nothing
detectSeed :: MonadIO m => m Seed
detectSeed :: forall (m :: * -> *). MonadIO m => m Seed
detectSeed =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Maybe String
menv <- String -> IO (Maybe String)
lookupEnv String
"HEDGEHOG_SEED"
case String -> Maybe Seed
parseSeed forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
menv of
Maybe Seed
Nothing ->
forall (m :: * -> *). MonadIO m => m Seed
Seed.random
Just Seed
seed ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seed
seed
detectVerbosity :: MonadIO m => m Verbosity
detectVerbosity :: forall (m :: * -> *). MonadIO m => m Verbosity
detectVerbosity =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Maybe Int
menv <- (forall a. Read a => String -> Maybe a
readMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) 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) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
Quiet
Just (Int
1 :: Int) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
Normal
Maybe Int
_ -> do
Bool
mth <- forall (m :: * -> *). MonadIO m => m Bool
detectMark
if Bool
mth then
forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
Quiet
else
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
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Maybe Int
menv <- (forall a. Read a => String -> Maybe a
readMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
Conc.getNumProcessors
Just Int
env ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 ->
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 ->
forall a. HasCallStack => String -> a
error String
"HEDGEHOG_SKIP is not a valid Skip."
Just Skip
skip ->
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 ->
forall (m :: * -> *). MonadIO m => m UseColor
detectColor
Just UseColor
x ->
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 ->
forall (m :: * -> *). MonadIO m => m Seed
detectSeed
Just Seed
x ->
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 ->
forall (m :: * -> *). MonadIO m => m Verbosity
detectVerbosity
Just Verbosity
x ->
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 ->
forall (m :: * -> *). MonadIO m => m WorkerCount
detectWorkers
Just WorkerCount
x ->
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 ->
forall (m :: * -> *). MonadIO m => m Skip
detectSkip
Just Skip
x ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Skip
x