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
module Color_mode = struct
include Err.Color_mode
let to_fmt_style_renderer = function
| `Auto -> None
| `Always -> Some `Ansi_tty
| `Never -> Some `None
;;
end
module Log_level = struct
include Err.Log_level
let of_logs_level : Logs.level option -> t = function
| None -> Quiet
| Some App -> App
| Some Error -> Error
| Some Warning -> Warning
| Some Info -> Info
| Some Debug -> Debug
;;
let to_logs_level : t -> Logs.level option = function
| Quiet -> None
| App -> Some App
| Error -> Some Error
| Warning -> Some Warning
| Info -> Some Info
| Debug -> Some Debug
;;
end
module Config = struct
let log_level_arg =
let open Command.Std in
let+ verbose_count =
Arg.flag_count
[ "verbose"; "v" ]
~doc:"Increase verbosity. Repeatable, but more than twice does not bring more."
and+ verbosity =
Arg.named_opt
[ "log-level"; "verbosity" ]
(Param.enumerated (module Log_level))
~docv:"LEVEL"
~doc:"Be more or less verbose. Takes over $(b,v)."
and+ quiet =
Arg.flag [ "quiet"; "q" ] ~doc:"Be quiet. Takes over $(b,v) and $(b,--verbosity)."
in
if quiet
then Log_level.Quiet
else (
match verbosity with
| Some verbosity -> verbosity
| None ->
(match verbose_count with
| 0 -> Log_level.Warning
| 1 -> Log_level.Info
| _ -> Log_level.Debug))
;;
let color_mode_arg =
let open Command.Std in
Arg.named_with_default
[ "color" ]
(Param.enumerated (module Color_mode))
~default:`Auto
~docv:"WHEN"
~doc:"Colorize the output."
;;
type t =
{ log_level : Log_level.t
; color_mode : Color_mode.t
; warn_error : bool
}
let default = { log_level = Log_level.Warning; color_mode = `Auto; warn_error = false }
let create
?(log_level = default.log_level)
?(color_mode = default.color_mode)
?(warn_error = default.warn_error)
()
=
{ log_level; color_mode; warn_error }
;;
let log_level t = t.log_level
let logs_level t = Log_level.to_logs_level t.log_level
let color_mode t = t.color_mode
let fmt_style_renderer t = Color_mode.to_fmt_style_renderer t.color_mode
let warn_error t = t.warn_error
let arg =
let open Command.Std in
let+ warn_error = Arg.flag [ "warn-error" ] ~doc:"Treat warnings as errors."
and+ log_level = log_level_arg
and+ color_mode = color_mode_arg in
{ log_level; color_mode; warn_error }
;;
let to_args { log_level; color_mode; warn_error } =
List.concat
[ (match Log_level.to_logs_level log_level with
| None -> [ "--quiet" ]
| Some level ->
(match level with
| App -> [ "--verbosity"; "app" ]
| Error -> [ "--verbosity"; "error" ]
| Warning -> []
| Info -> [ "--verbosity"; "info" ]
| Debug -> [ "--verbosity"; "debug" ]))
; (match color_mode with
| `Auto -> []
| `Always -> [ "--color"; "always" ]
| `Never -> [ "--color"; "never" ])
; (if warn_error then [ "--warn-error" ] else [])
]
;;
end
let setup_log ~(config : Config.t) =
Fmt_tty.setup_std_outputs
?style_renderer:(Color_mode.to_fmt_style_renderer config.color_mode)
();
let () = Err.Private.color_mode := config.color_mode in
Logs.set_level (Log_level.to_logs_level config.log_level);
let () =
Err.Private.set_log_level
~get:(fun () -> Log_level.of_logs_level (Logs.level ()))
~set:(fun level -> (Logs.set_level (Log_level.to_logs_level level) [@coverage off]))
in
Logs.set_reporter (Logs_fmt.reporter ())
;;
let setup_config ~config =
setup_log ~config;
Err.Private.warn_error := config.warn_error;
Err.Private.set_log_counts ~err_count:Logs.err_count ~warn_count:Logs.warn_count;
()
;;
let set_config () =
let open Command.Std in
let+ config = Config.arg in
setup_config ~config
;;