/
Config.hs
157 lines (131 loc) · 3.45 KB
/
Config.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Hedgehog.Internal.Config (
UseColor(..)
, resolveColor
, Verbosity(..)
, resolveVerbosity
, WorkerCount(..)
, resolveWorkers
, detectMark
, detectColor
, detectVerbosity
, detectWorkers
) where
import Control.Monad.IO.Class (MonadIO(..))
import qualified GHC.Conc as Conc
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 (Eq, Ord, Show, 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 (Eq, Ord, Show, Lift)
-- | The number of workers to use when running properties in parallel.
--
newtype WorkerCount =
WorkerCount Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)
detectMark :: MonadIO m => m Bool
detectMark = do
user <- liftIO $ lookupEnv "USER"
pure $ user == Just "mth"
lookupBool :: MonadIO m => String -> m (Maybe Bool)
lookupBool key =
liftIO $ do
menv <- lookupEnv key
case menv of
Just "0" ->
pure $ Just False
Just "no" ->
pure $ Just False
Just "false" ->
pure $ Just False
Just "1" ->
pure $ Just True
Just "yes" ->
pure $ Just True
Just "true" ->
pure $ Just True
_ ->
pure Nothing
detectColor :: MonadIO m => m UseColor
detectColor =
liftIO $ do
ok <- lookupBool "HEDGEHOG_COLOR"
case ok of
Just False ->
pure DisableColor
Just True ->
pure EnableColor
Nothing -> do
mth <- detectMark
if mth then
pure DisableColor -- avoid getting fired :)
else do
enable <- hSupportsANSI stdout
if enable then
pure EnableColor
else
pure DisableColor
detectVerbosity :: MonadIO m => m Verbosity
detectVerbosity =
liftIO $ do
menv <- (readMaybe =<<) <$> lookupEnv "HEDGEHOG_VERBOSITY"
case menv of
Just (0 :: Int) ->
pure Quiet
Just (1 :: Int) ->
pure Normal
_ -> do
mth <- detectMark
if mth then
pure Quiet
else
pure Normal
detectWorkers :: MonadIO m => m WorkerCount
detectWorkers = do
liftIO $ do
menv <- (readMaybe =<<) <$> lookupEnv "HEDGEHOG_WORKERS"
case menv of
Nothing ->
WorkerCount <$> Conc.getNumProcessors
Just env ->
pure $ WorkerCount env
resolveColor :: MonadIO m => Maybe UseColor -> m UseColor
resolveColor = \case
Nothing ->
detectColor
Just x ->
pure x
resolveVerbosity :: MonadIO m => Maybe Verbosity -> m Verbosity
resolveVerbosity = \case
Nothing ->
detectVerbosity
Just x ->
pure x
resolveWorkers :: MonadIO m => Maybe WorkerCount -> m WorkerCount
resolveWorkers = \case
Nothing ->
detectWorkers
Just x ->
pure x