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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
open B0_std
open B0_testing
open Cmdliner
(* Snapshotting command line evaluations *)
let capture_fmt f =
let buf = Buffer.create 255 in
let fmt = Format.formatter_of_buffer buf in
let ret = f fmt in
ret, (Buffer.contents buf)
let make_argv cmd args = Array.of_list (Cmd.name cmd :: args)
let env_dumb_term = function
| "TERM" -> Some "dumb"
| var -> Sys.getenv_opt var
let t_eval_result ok =
let test_eval_error : Cmd.eval_error Test.T.t =
let pp ppf = function
| `Parse -> Fmt.string ppf "`Parse"
| `Term -> Fmt.string ppf "`Term"
| `Exn -> Fmt.string ppf "`Exn"
in
Test.T.make ~equal:(=) ~pp ()
in
let test_eval_ok ok =
let pp ppf = function
| `Ok v -> Test.T.pp ok ppf v
| `Version -> Fmt.string ppf "`Version"
| `Help -> Fmt.string ppf "`Help"
in
let equal v0 v1 = match v0, v1 with
| `Ok v0, `Ok v1 -> Test.T.equal ok v0 v1
| v0, v1 -> v0 = v1
in
Test.T.make ~equal ~pp ()
in
Test.T.result' ~ok:(test_eval_ok ok) ~error:test_eval_error
let get_eval_value ?__POS__ = function
| Ok (`Ok v) -> v
| (Error _ | Ok `Version | Ok `Help) as v ->
Test.failstop ?__POS__ "Unexpected evalution: %a"
(Test.T.pp (t_eval_result Test.T.any)) v
let test_eval_result ?__POS__ ?env t cmd args exp =
let argv = make_argv cmd args in
let (ret, _), _ = (* Ignore outputs *)
capture_fmt @@ fun err ->
capture_fmt @@ fun help ->
Cmd.eval_value ?env ~help ~err cmd ~argv
in
Test.eq ?__POS__ (t_eval_result t) ret exp
let snap_parse ?env t cmd args exp =
let loc = Test.Snapshot.loc exp in
let argv = make_argv cmd args in
let ret = Cmd.eval_value ?env cmd ~argv in
Test.snap t (get_eval_value ~__POS__:loc ret) exp
let snap_parse_warnings ?env cmd args exp =
let loc = Test.Snapshot.loc exp in
let argv = make_argv cmd args in
let ret, err = capture_fmt @@ fun err -> Cmd.eval_value ?env ~err cmd ~argv in
ignore (get_eval_value ~__POS__:loc ret);
Snap.lines err exp
let snap_eval_error ?env error cmd args exp =
let loc = Test.Snapshot.loc exp in
let argv = make_argv cmd args in
let ret, err = capture_fmt @@ fun err -> Cmd.eval_value ?env ~err cmd ~argv in
Test.eq (t_eval_result Test.T.any) ret (Error error) ~__POS__:loc ;
Snap.lines err exp
let snap_help ?env retv cmd args exp =
let loc = Test.Snapshot.loc exp in
let argv = make_argv cmd args in
let (ret, help), err =
capture_fmt @@ fun err ->
capture_fmt @@ fun help -> Cmd.eval_value ?env ~help ~err cmd ~argv
in
Test.string err "";
Test.eq (t_eval_result Test.T.any) ret retv ~__POS__:loc;
Snap.lines help exp
let snap_completion ?env cmd args exp =
snap_help ?env (Ok `Help) cmd ("--__complete" :: args) exp
let snap_man ?env ?(args = ["--help=plain"]) cmd exp =
snap_help ?env (Ok `Help) cmd args exp
(* Sample commands *)
open Cmdliner
open Cmdliner.Term.Syntax
let sample_group_cmd =
let man = [ `P "Invoke command with $(cmd), the command name is \
$(cmd.name), the parent is $(cmd.parent) and the tool \
name is $(tool)." ] in
let kind =
let doc = "Kind of entity" in
Arg.(value & opt (some string) None & info ["k";"kind"] ~doc)
in
let speed =
let doc = "Movement $(docv) in m/s" in
Arg.(value & opt int 2 & info ["speed"] ~doc ~docv:"SPEED")
in
let can_fly =
let doc = "$(docv) indicates if the entity can fly." in
Arg.(value & opt bool false & info ["can-fly"] ~doc)
in
let birds =
let bird =
let doc = "Use $(docv) specie." in
Arg.(value & pos 0 string "pigeon" & info [] ~doc ~docv:"BIRD")
in
let fly =
Cmd.make (Cmd.info "fly" ~doc:"Fly birds." ~man) @@
let+ bird and+ speed in ()
in
let land' =
Cmd.make (Cmd.info "land" ~doc:"Land birds." ~man) @@
let+ bird in ()
in
let info = Cmd.info "birds" ~doc:"Operate on birds." ~man in
Cmd.group ~default:Term.(const (fun _ _-> ()) $ kind $ can_fly) info @@
[fly; land']
in
let mammals =
let man_xrefs = [`Main; `Cmd "birds" ] and doc = "Operate on mammals." in
Cmd.make (Cmd.info "mammals" ~doc ~man_xrefs ~man) @@
Term.(const (fun () -> ()) $ const ())
in
let fishs =
let name' =
let doc = "Use fish named $(docv)." in
Arg.(value & pos 0 (some string) None & info [] ~doc ~docv:"NAME")
in
Cmd.make (Cmd.info "fishs" ~doc:"Operate on fishs." ~man) @@
let+ name' in ()
in
let camels =
let herd =
let doc = "Find in herd $(docv)." and docv = "HERD" in
let deprecated = "Herds $(docv) are ignored." in
Arg.(value & pos 0 (some string) None & info [] ~deprecated ~doc ~docv)
in
let bactrian =
let deprecated = "Use nothing instead of $(env), $(b,HA!)." in
let doc = "Specify a bactrian camel." in
let env = Cmd.Env.info "BACTRIAN" ~deprecated in
Arg.(value & flag & info ["bactrian"; "b"] ~deprecated ~env ~doc)
in
let deprecated = "Use $(b,mammals) instead." in
Cmd.make (Cmd.info "camels" ~deprecated ~doc:"Operate on camels." ~man) @@
let+ bactrian and+ herd in ()
in
let lookup =
let kind_opt =
let kinds = ["bird", `Bird; "fish", `Fish] in
let doc =
"$(docv) restricts the animal kind. Must be " ^ Arg.doc_alts_enum kinds
in
Arg.(value & opt (some (enum kinds)) None & info ["k"; "kind"] ~doc)
in
let name_conv =
let bird_names = ["sparrow"; "parrot"; "pigeon"] in
let fish_names = ["salmon"; "trout"; "piranha"] in
let completion =
let select ~token:prefix n =
if String.starts_with ~prefix n
then Some (Arg.Completion.string n) else None
in
let func kind ~token = match Option.join kind with
| None -> Ok (List.filter_map (select ~token) (bird_names @ fish_names))
| Some `Bird -> Ok (List.filter_map (select ~token) bird_names)
| Some `Fish -> Ok (List.filter_map (select ~token) fish_names)
in
Arg.Completion.make ~context:kind_opt func
in
Arg.Conv.of_conv Arg.string ~completion
in
Cmd.make (Cmd.info "lookup" ~doc:"Lookup animal by name.") @@
let+ kind_opt
and+ name =
let doc = "$(docv) is the animal name to lookup" and docv = "NAME" in
Arg.(required & pos 0 (some name_conv) None & info [] ~doc ~docv)
in
()
in
Cmd.group (Cmd.info "test_group" ~version:"X.Y.Z" ~man) @@
[birds; mammals; fishs; camels; lookup]
|
