0 | module Hedgehog.Internal.Config
 1 |
 2 | import Derive.Prelude
 3 | import System
 4 |
 5 | %language ElabReflection
 6 |
 7 | %default total
 8 |
 9 | --------------------------------------------------------------------------------
10 | --          Config
11 | --------------------------------------------------------------------------------
12 |
13 | ||| Whether to render output using ANSI colors or not.
14 | public export
15 | data UseColor = DisableColor | EnableColor
16 |
17 | %runElab derive "UseColor" [Show,Eq,Ord]
18 |
19 | ||| How verbose should the report output be.
20 | public export
21 | data Verbosity = Quiet | Normal
22 |
23 | %runElab derive "Verbosity" [Show,Eq,Ord]
24 |
25 | --------------------------------------------------------------------------------
26 | --          Detecting Config Settings
27 | --------------------------------------------------------------------------------
28 |
29 | ||| Defines points of an global configuration for a Hedgehog run
30 | public export
31 | interface HasConfig m where
32 |   constructor MkHasConfig
33 |   detectColor     : m UseColor
34 |   detectVerbosity : m Verbosity
35 |
36 | export
37 | resolveColor : HasConfig m => Applicative m => Maybe UseColor -> m UseColor
38 | resolveColor = maybe detectColor pure
39 |
40 | export
41 | resolveVerbosity : HasConfig m => Applicative m => Maybe Verbosity -> m Verbosity
42 | resolveVerbosity = maybe detectVerbosity pure
43 |
44 | lookupBool : HasIO io => String -> io (Maybe Bool)
45 | lookupBool key =
46 |   getEnv key >>=
47 |     \case
48 |       Just "0"     => pure $ Just False
49 |       Just "no"    => pure $ Just False
50 |       Just "false" => pure $ Just False
51 |
52 |       Just "1"     => pure $ Just True
53 |       Just "yes"   => pure $ Just True
54 |       Just "true"  => pure $ Just True
55 |
56 |       _            => pure Nothing
57 |
58 | ||| Reads the global configuration from environment variables
59 | export
60 | HasIO io => HasConfig io where
61 |   detectColor = do
62 |     Just True <- lookupBool "HEDGEHOG_COLOR" | _ => pure DisableColor
63 |     pure EnableColor
64 |
65 |   detectVerbosity = do
66 |     Just "0" <- getEnv "HEDGEHOG_VERBOSITY" | _ => pure Normal
67 |     pure Quiet
68 |
69 | ||| Uses the most conservative configuration
70 | |||
71 | ||| This implementation is applicable for any applicative context,
72 | ||| including pure ones.
73 | export %defaulthint
74 | DefaultConfig : Applicative m => HasConfig m
75 | DefaultConfig = D where
76 |   [D] HasConfig m where
77 |     detectColor     = pure DisableColor
78 |     detectVerbosity = pure Normal
79 |