Cmdliner terms for ergonomic logging configuration
fix(ocaml-vlog): fix all merlint issues (E010/E205/E350/E600/E605)
- Extract level_string, write_json_trace, write_tracing_entry, is_tracing_src,
report_tracing helpers to reduce trace_reporter nesting depth (E010)
- Replace Format.kfprintf with Fmt.kstr/Fmt.kpf (E205)
- Introduce log_flags record to eliminate 2 bool params in setup_log (E350)
- Add test_cli.mli, test_cli_no_json.mli with suite exports (E600)
- Add test_vlog.ml/mli with tests for parse_log_spec, level_of_verbosity,
enable_tracing; add test.ml runner (E605)
+155
-23
+30
-21
lib/vlog.ml
+30
-21
lib/vlog.ml
···
128
128
(fun msg ->
129
129
write_json_trace ppf ~ts ~name ~level_s:(level_string level) msg k)
130
130
fmt
131
-
else Fmt.kpf k ppf ("%s %s " ^^ fmt ^^ "@.") ts name
131
+
else Fmt.kpf (fun _ -> k ()) ppf ("%s %s " ^^ fmt ^^ "@.") ts name
132
+
133
+
let is_tracing_src name =
134
+
String.length name > 8
135
+
&& String.sub name (String.length name - 8) 8 = ".tracing"
136
+
137
+
let report_tracing ~json ppf ~name level ~over k msgf =
138
+
msgf @@ fun ?header:_ ?tags:_ fmt ->
139
+
let k _ =
140
+
over ();
141
+
k ()
142
+
in
143
+
let ts = Ptime_clock.now () |> Ptime.to_rfc3339 in
144
+
write_tracing_entry ~json ppf ts name level fmt k
132
145
133
146
let trace_reporter ~json file_path =
134
147
let oc = open_out file_path in
135
148
let ppf = Format.formatter_of_out_channel oc in
136
149
let report src level ~over k msgf =
137
150
let name = Logs.Src.name src in
138
-
(* Only capture *.tracing sources *)
139
-
if
140
-
String.length name > 8
141
-
&& String.sub name (String.length name - 8) 8 = ".tracing"
142
-
then
143
-
msgf @@ fun ?header:_ ?tags:_ fmt ->
144
-
let k _ =
145
-
over ();
146
-
k ()
147
-
in
148
-
let ts = Ptime_clock.now () |> Ptime.to_rfc3339 in
149
-
write_tracing_entry ~json ppf ts name level fmt k
151
+
if is_tracing_src name then
152
+
report_tracing ~json ppf ~name level ~over k msgf
150
153
else (
151
154
over ();
152
155
k ())
···
228
231
Logs.set_reporter (Logs_fmt.reporter ());
229
232
apply_source_overrides source_overrides
230
233
231
-
let setup_log ~json_reporter app_name style_renderer quiet verbosity log_spec
232
-
trace_file base_tags json =
234
+
type log_flags = { quiet : bool; json : bool }
235
+
236
+
let setup_log ~json_reporter app_name style_renderer { quiet; json } verbosity
237
+
log_spec trace_file base_tags =
233
238
Fmt_tty.setup_std_outputs ?style_renderer ();
234
239
(* Parse --log / <APP>_LOG spec *)
235
240
let global_override, source_overrides =
···
276
281
| Some None -> None (* explicitly disabled *)
277
282
| Some (Some r) -> Some r (* custom reporter *)
278
283
in
284
+
let flags_term =
285
+
Term.(const (fun quiet json -> { quiet; json }) $ quiet $ json)
286
+
in
279
287
match json_reporter with
280
288
| None ->
281
289
(* JSON disabled: no --json flag or --log-tag exposed *)
282
-
let setup_log' style_renderer quiet verbosity log_spec trace_file =
290
+
let setup_log' style_renderer flags verbosity log_spec trace_file =
283
291
setup_log
284
292
~json_reporter:(fun ~app:_ ~base:_ () -> Logs_fmt.reporter ())
285
-
app_name style_renderer quiet verbosity log_spec trace_file [] false
293
+
app_name style_renderer flags verbosity log_spec trace_file []
286
294
in
287
295
Term.(
288
-
const setup_log' $ Fmt_cli.style_renderer () $ quiet $ verbosity
289
-
$ log_term app_name $ trace_file)
296
+
const setup_log' $ Fmt_cli.style_renderer ()
297
+
$ Term.(const (fun quiet -> { quiet; json = false }) $ quiet)
298
+
$ verbosity $ log_term app_name $ trace_file)
290
299
| Some r ->
291
300
(* JSON enabled: expose --json flag and --log-tag *)
292
301
Term.(
293
302
const (setup_log ~json_reporter:r app_name)
294
-
$ Fmt_cli.style_renderer () $ quiet $ verbosity $ log_term app_name
295
-
$ trace_file $ log_tags $ json)
303
+
$ Fmt_cli.style_renderer () $ flags_term $ verbosity $ log_term app_name
304
+
$ trace_file $ log_tags)
+9
-2
test/dune
+9
-2
test/dune
···
1
+
(test
2
+
(name test)
3
+
(modules test test_vlog)
4
+
(libraries vlog alcotest logs))
5
+
1
6
(executable
2
7
(name test_cli)
3
-
(libraries vlog logs))
8
+
(modules test_cli)
9
+
(libraries vlog logs alcotest))
4
10
5
11
(executable
6
12
(name test_cli_no_json)
7
-
(libraries vlog logs))
13
+
(modules test_cli_no_json)
14
+
(libraries vlog logs alcotest))
8
15
9
16
(cram
10
17
(deps test_cli.exe test_cli_no_json.exe))
+6
test/test.ml
+6
test/test.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let () = Alcotest.run "vlog" [ Test_vlog.suite ]
+2
test/test_cli.ml
+2
test/test_cli.ml
+8
test/test_cli.mli
+8
test/test_cli.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Test CLI executable for vlog cram tests. *)
7
+
8
+
val suite : string * unit Alcotest.test_case list
+2
test/test_cli_no_json.ml
+2
test/test_cli_no_json.ml
+8
test/test_cli_no_json.mli
+8
test/test_cli_no_json.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Test CLI executable for vlog cram tests (JSON disabled). *)
7
+
8
+
val suite : string * unit Alcotest.test_case list
+83
test/test_vlog.ml
+83
test/test_vlog.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Vlog. *)
7
+
8
+
let test_parse_log_spec_global () =
9
+
let level, srcs = Vlog.parse_log_spec "debug" in
10
+
Alcotest.(check (option (of_pp Logs.pp_level)))
11
+
"global level" (Some Logs.Debug) level;
12
+
Alcotest.(check (list (pair string (option (of_pp Logs.pp_level)))))
13
+
"no sources" [] srcs
14
+
15
+
let test_parse_log_spec_source () =
16
+
let level, srcs = Vlog.parse_log_spec "info,http:debug" in
17
+
Alcotest.(check (option (of_pp Logs.pp_level)))
18
+
"global info" (Some Logs.Info) level;
19
+
Alcotest.(check int) "one source" 1 (List.length srcs);
20
+
let src_name, src_level = List.hd srcs in
21
+
Alcotest.(check string) "source name" "http" src_name;
22
+
Alcotest.(check (option (of_pp Logs.pp_level)))
23
+
"source level" (Some Logs.Debug) src_level
24
+
25
+
let test_parse_spec_src_only () =
26
+
let level, srcs = Vlog.parse_log_spec "conpool:warning" in
27
+
Alcotest.(check (option (of_pp Logs.pp_level))) "no global" None level;
28
+
Alcotest.(check int) "one source" 1 (List.length srcs);
29
+
let src_name, src_level = List.hd srcs in
30
+
Alcotest.(check string) "source name" "conpool" src_name;
31
+
Alcotest.(check (option (of_pp Logs.pp_level)))
32
+
"source level" (Some Logs.Warning) src_level
33
+
34
+
let test_level_of_verbosity_quiet () =
35
+
let level = Vlog.level_of_verbosity ~quiet:true ~verbosity:[] in
36
+
Alcotest.(check (option (of_pp Logs.pp_level)))
37
+
"quiet=error" (Some Logs.Error) level
38
+
39
+
let test_level_of_verbosity_default () =
40
+
let level = Vlog.level_of_verbosity ~quiet:false ~verbosity:[] in
41
+
Alcotest.(check (option (of_pp Logs.pp_level)))
42
+
"default=warning" (Some Logs.Warning) level
43
+
44
+
let test_level_of_verbosity_v () =
45
+
let level = Vlog.level_of_verbosity ~quiet:false ~verbosity:[ true ] in
46
+
Alcotest.(check (option (of_pp Logs.pp_level)))
47
+
"-v=info" (Some Logs.Info) level
48
+
49
+
let test_level_of_verbosity_vv () =
50
+
let level = Vlog.level_of_verbosity ~quiet:false ~verbosity:[ true; true ] in
51
+
Alcotest.(check (option (of_pp Logs.pp_level)))
52
+
"-vv=debug" (Some Logs.Debug) level
53
+
54
+
let test_enable_tracing_false () =
55
+
Alcotest.(check bool)
56
+
"no tracing by default" false
57
+
(Vlog.enable_tracing ~verbosity:[])
58
+
59
+
let test_enable_tracing_vvv () =
60
+
Alcotest.(check bool)
61
+
"tracing at -vvv" true
62
+
(Vlog.enable_tracing ~verbosity:[ true; true; true ])
63
+
64
+
let suite =
65
+
( "vlog",
66
+
[
67
+
Alcotest.test_case "parse_log_spec global" `Quick
68
+
test_parse_log_spec_global;
69
+
Alcotest.test_case "parse_log_spec source" `Quick
70
+
test_parse_log_spec_source;
71
+
Alcotest.test_case "parse_log_spec src only" `Quick
72
+
test_parse_spec_src_only;
73
+
Alcotest.test_case "level_of_verbosity quiet" `Quick
74
+
test_level_of_verbosity_quiet;
75
+
Alcotest.test_case "level_of_verbosity default" `Quick
76
+
test_level_of_verbosity_default;
77
+
Alcotest.test_case "level_of_verbosity -v" `Quick
78
+
test_level_of_verbosity_v;
79
+
Alcotest.test_case "level_of_verbosity -vv" `Quick
80
+
test_level_of_verbosity_vv;
81
+
Alcotest.test_case "enable_tracing false" `Quick test_enable_tracing_false;
82
+
Alcotest.test_case "enable_tracing -vvv" `Quick test_enable_tracing_vvv;
83
+
] )
+7
test/test_vlog.mli
+7
test/test_vlog.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
val suite : string * unit Alcotest.test_case list
7
+
(** [suite] is the Alcotest test suite for [Vlog]. *)