swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

7
unikernel/duniverse/cmdliner/.gitignore vendored Normal file
View file

@ -0,0 +1,7 @@
_build
_b0
tmp
test/b0
*.byte
*.native
cmdliner.install

3
unikernel/duniverse/cmdliner/.merlin Normal file
View file

@ -0,0 +1,3 @@
S src
S test
B _b0/b/**

1
unikernel/duniverse/cmdliner/.ocp-indent Normal file
View file

@ -0,0 +1 @@
strict_with=always,match_clause=4,strict_else=never

105
unikernel/duniverse/cmdliner/B0.ml Normal file
View file

@ -0,0 +1,105 @@
[@@@B0.include "test/b0/B0.ml"]
(* See DEVEL.md for an explanation for the above line *)
open B0_kit.V000
open Result.Syntax
(* OCaml library names *)
let b0_std = B0_ocaml.libname "b0.std"
let cmdliner = B0_ocaml.libname "cmdliner"
(* Units *)
let cmdliner_lib =
B0_ocaml.lib cmdliner ~name:"cmdliner-lib" ~srcs:[`Dir ~/"src"]
(* Tool *)
let cmdliner_tool =
let srcs = [`Dir ~/"src/tool"] in
B0_ocaml.exe "cmdliner" ~public:true ~srcs ~requires:[cmdliner]
(* Tests *)
let test ?(requires = []) = B0_ocaml.test ~requires:(cmdliner :: requires)
let testing = `File ~/"test/testing_cmdliner.ml"
let test_arg = test ~/"test/test_arg.ml" ~srcs:[testing] ~requires:[b0_std]
let test_cmd = test ~/"test/test_cmd.ml" ~srcs:[testing] ~requires:[b0_std]
let test_completion =
test ~/"test/test_completion.ml" ~srcs:[testing] ~requires:[b0_std]
let test_deprecation =
test ~/"test/test_deprecation.ml" ~srcs:[testing] ~requires:[b0_std]
let test_legacy_prefix =
test ~/"test/test_legacy_prefix.ml" ~srcs:[testing] ~requires:[b0_std]
let test_man = test ~/"test/test_man.ml" ~srcs:[testing] ~requires:[b0_std]
let test_term = test ~/"test/test_term.ml" ~srcs:[testing] ~requires:[b0_std]
let example_chorus = test ~/"test/example_chorus.ml" ~run:false
let example_cp = test ~/"test/example_cp.ml" ~run:false
let example_darcs = test ~/"test/example_darcs.ml" ~run:false
let example_group =
let srcs = [testing] and requires = [b0_std] in
test ~/"test/example_group.ml" ~run:false ~srcs ~requires
let example_revolt1 = test ~/"test/example_revolt1.ml" ~run:false
let example_revolt2 = test ~/"test/example_revolt2.ml" ~run:false
let example_rm = test ~/"test/example_rm.ml" ~run:false
let example_tail = test ~/"test/example_tail.ml" ~run:false
let blueprint_min = test ~/"test/blueprint_min.ml" ~run:false
let blueprint_tool = test ~/"test/blueprint_tool.ml" ~run:false
let blueprint_cmds = test ~/"test/blueprint_cmds.ml" ~run:false
(* Completion scripts update *)
let update_completion_scripts =
B0_unit.of_action "update-cmdliner-data" @@ fun env _ ~args:_ ->
let bash = B0_env.in_scope_dir env ~/"src/tool/bash-completion.sh" in
let zsh = B0_env.in_scope_dir env ~/"src/tool/zsh-completion.sh" in
let ml = B0_env.in_scope_dir env ~/"src/tool/cmdliner_data.ml" in
let* bash = Os.File.read bash in
let* zsh = Os.File.read zsh in
let src = Fmt.str
"let bash_generic_completion =\n{|%s\
|}\n\n\
let zsh_generic_completion =\n{|%s\
|}" bash zsh
in
Os.File.write ~force:true ~make_path:false ml src
(* Packs *)
(* FIXME b0 it's unclear whether the fact that the @@@B0.included units
show up in B0_unit.list () is a bug or a feature. If it's a bug
the filter on B0_unit.in_current_scope could be avoided. *)
let default =
let meta =
B0_meta.empty
|> ~~ B0_meta.authors ["The cmdliner programmers"]
|> ~~ B0_meta.maintainers ["Daniel Bünzli <daniel.buenzl i@erratique.ch>"]
|> ~~ B0_meta.homepage "https://erratique.ch/software/cmdliner"
|> ~~ B0_meta.online_doc "https://erratique.ch/software/cmdliner/doc"
|> ~~ B0_meta.issues "https://github.com/dbuenzli/cmdliner/issues"
|> ~~ B0_meta.repo "git+https://erratique.ch/repos/cmdliner.git"
|> ~~ B0_meta.licenses ["ISC"]
|> ~~ B0_meta.description_tags
["cli"; "system"; "declarative"; "org:erratique"]
|> ~~ B0_opam.depends [ "ocaml", {|>= "4.08.0"|}; ]
|> ~~ B0_opam.build {|[[ make "all" "PREFIX=%{prefix}%" ]]|}
|> ~~ B0_opam.install
{|[[make "install" "BINDIR=%{_:bin}%" "LIBDIR=%{_:lib}%" "DOCDIR=%{_:doc}%"
"SHAREDIR=%{share}%" "MANDIR=%{man}%"]
[make "install-doc" "LIBDIR=%{_:lib}%" "DOCDIR=%{_:doc}%"
"SHAREDIR=%{share}%" "MANDIR=%{man}%"]]|}
|> B0_meta.tag B0_opam.tag
in
let locked = false (* So that it looks up b0.std *) in
B0_pack.make "default" ~doc:"cmdliner package" ~meta ~locked @@
List.filter B0_unit.in_current_scope (B0_unit.list ())

1
unikernel/duniverse/cmdliner/BRZO Normal file
View file

@ -0,0 +1 @@
(srcs-x build.ml test pkg)

565
unikernel/duniverse/cmdliner/CHANGES.md Normal file
View file

@ -0,0 +1,565 @@
v2.0.0 2025-09-26 Zagreb
------------------------
### End-user visible changes
- **IMPORTANT** Cmdliner no longer allows command names, option names,
and `Arg.enum` values to be specified by a prefix if the prefix is
unambiguous. See #200 for the rationale. To quickly salvage scripts
that may be relying on the old behaviour, it can be restored by
setting the environment variable `CMDLINER_LEGACY_PREFIXES=true`.
However the scripts should be fixed: this escape hatch will be
removed in the future.
- Pager. If set, respect the user's `LESS` environment variable
(otherwise the default `LESS=FRX` is left unchanged). Note however
that you likely need at least `R` specified if you define it
yourself, otherwise the manpage may look garbled (#191). Thanks to
Yukai Chou for suggesting.
- Fix lack of output whenever `PAGER` or `MANPAGER` is set but empty;
fallback to pager discovery (#194). For example this prevented to
see manpages in `emacs`'s compilation mode which unhelpfully
hardcodes `PAGER=""`.
- Fix synopsis rendering of required optional arguments (#203).
- Output error messages on `stderr` with styled text (#144). Quoted
and typewriter text is in bold. Variables are written as
underlines. Key words of error messages are in red.
- Output error messages after the usage line and remove the `Try with
$(tool) --help for more information` message. Instead we explicitly
indicate the `--help` option in the usage line. Having the error message
at the end makes it easier to spot.
- Make `--help` request work in any context, except after `--` or on
the arguments after an unknown command error in which case that
error is reported (less confusing). Since the option has an optional
argument value, one had to be carefull that it would not pickup the
next argument and try to parse it according to `FMT`. This is no
longer the case. If the argument fails to parse `--help=auto` is
assumed. (#201).
- Deprecation messages are now prepended to the doc strings in the manpage.
### API changes
- Reserve the `--__complete` option for library use.
- Documentation language, `$(cmd)`, `$(cmd.name)` and `$(tool)` can be
used and should be prefered over of `$(iname)`, `$(tname)` and
`$(mname)`. `$(cmd.parent)` is added to refer to a command's parent
or itself at the root.
- Make `Cmdliner.Arg.conv` abstract. Thanks to Andrey Popp for
the patch (#206).
- Thanks to the previous point, use the `docv` parameter of argument
converters can now be used to define the default value used by `docv` in
`Arg.info`. See `Arg.Conv.docv`.
- Add `Manpage.section_name` type alias (#202).
- Add `Cmd.make` which should be preferred to `Cmd.v` (The `M.v` notation is
nice for simulating literals, not for heavy constructor).
- Add `Cmd.Env.info_var`. To get back the environment variable name
from a variable info.
- Add optional `doc_envs` argument to `Arg.info` for adding the given
environment variables info to the command in which the argument is used.
Sometimes more than one variable make sense and the `env` argument is
not directly used.
- Add `Arg.Completion` a module to define argument completion
strategies (#1, #187).
- Add `Arg.Conv` module to define converters. This should be used in
new code.
- Add `Arg.{file,dir,}path` string converters equiped with appropriate
file system completions.
- Add `docv` optional parameter to `Arg.enum`.
- Add `Term.env` which provides access to the environment access
function provided to evaluation functions.
- Clarify the semantics of the `deprecated` argument of
`Cmdliner.Cmd.info`, `Cmdliner.Arg.info` and
`Cmdliner.Cmd.Env.info`. First, the language markup is now supported
therein. Second the message is no longer only used to warn about
usage it is now also prepended to the doc string of the entity.
- Use `Arg.conv`'s `docv` property in the documentation of arguments
whenever `Arg.info`'s `docv` is unspecified (#207).
- Do not check file existence for `-` in `Arg.file` or
`Arg.non_dir_file` values. This is supposed to mean `stdin` or
`stdout` (#208).
- Fix manpage rendering performing direct calls to `Sys.getenv` in
`Cmd.eval*` functions instead of calling the `env` argument as
advertised in the docs. Incidentally add an `env` optional argument
to `Manpage.print` (#209).
- Deprecate. `Arg.{printer,conv_docv,conv_parser,
conv_printer,parser_of_kind_of_string,conv,conv'}`. These will
likely never be removed but they should no longer be used for
new code. Use `Arg.Conv`.
- Remove deprecated `Arg.{converter,parser,pconv}` (#206).
- Remove deprecated `Arg.{env,env_var}` (#206).
- Remove deprecated `Term.{pure,man_format}` (#206).
- Remove deprecated `Term` evaluation interface (#206).
### Other
- Install a `cmdliner` tool to help with manpage and completion script
installation. See the command line interface manual of the library
for more information (#187, #227, #228).
- Install all source files for `odoc` and goto definition editor
functionality. Thanks to Emile Trotignon and Paul-Elliot Anglès
d'Auriac for noticing and suggesting (#225).
- Added a proper test suite to the library to check for regressions.
Replaces most of the test executables that had to be run and inspected
manually (#205).
v1.3.0 2024-05-23 La Forclaz (VS)
---------------------------------
- Add let operators in `Cmdliner.Term.Syntax` (#173). Thanks to Benoit
Montagu for suggesting, Gabriel Scherer for reminding us of language
punning obscurities and Sebastien Mondet for strengthening the case
to add them.
- Pager. Support full path command lookups on Windows.
(#185). Thanks to @kit-ty-kate for the report.
- In manpage specifications use `$(iname)` in the default
introduction of the `ENVIRONMENT` section. Follow up to
#168.
- Add `Cmd.eval_value'` a variation on `Cmd.eval_value`.
v1.2.0 2023-04-10 La Forclaz (VS)
---------------------------------
- In manpage specification the new variable `$(iname)` substitutes the
command invocation (from program name to subcommand) in bold (#168).
This variable is now used in the default introduction of the `EXIT STATUS`
section. Thanks to Ali Caglayan for suggesting.
- Fix manpage rendering when `PAGER=less` is set (#167).
- Plain text manpage rendering: fix broken handling of `` `Noblank ``.
Thanks to Michael Richards and Reynir Björnsson for the report (#176).
- Fix install to directory with spaces (#172). Thanks to
@ZSFactory for reporting and suggesting the fix.
- Fix manpage paging on Windows (#166). Thanks to Nicolás Ojeda Bär
for the report and the solution.
v1.1.1 2022-03-23 La Forclaz (VS)
---------------------------------
- General documentation fixes, tweaks and improvements.
- Docgen: suppress trailing whitespace in synopsis rendering.
- Docgen: fix duplicate rendering of standard options when using `Term.ret` (#135).
- Docgen: fix duplicate rendering of command name on ``Term.ret (`Help (fmt, None)``
(#135).
v1.1.0 2022-02-06 La Forclaz (VS)
---------------------------------
- Require OCaml 4.08.
- Support for deprecating commands, arguments and environment variables (#66).
See the `?deprecated` argument of `Cmd.info`, `Cmd.Env.info` and `Arg.info`.
- Add `Manpage.s_none` a special section name to use whenever you
want something not to be listed in a command's manpage.
- Add `Arg.conv'` like `Arg.conv` but with a parser signature that returns
untagged string errors.
- Add `Term.{term,cli_parse}_result'` functions.
- Add deprecation alerts on what is already deprecated.
- On unices, use `command -v` rather than `type` to find commands.
- Stop using backticks for left quotes. Use apostrophes everywhere.
Thanks to Ryan Moore for reporting a typo that prompted the change (#128).
- Rework documentation structure. Move out tutorial, examples and
reference doc from the `.mli` to multiple `.mld` pages.
- `Arg.doc_alts` and `Arg.doc_alts_enum`, change the default rendering
to match the manpage convention which is to render these tokens in
bold. If you want to recover the previous rendering or were using
these functions outside man page rendering use an explicit
`~quoted:true` (the optional argument is available on earlier
versions).
- The deprecated `Term.exit` and `Term.exit_status_of_result` now
require a `unit` result. This avoids various errors to go undetected.
Thanks to Thomas Leonard for the patch (#124).
- Fix absent and default option values (`?none` string argument of `Arg.some`)
rendering in manpages:
1. They were not escaped, they now are.
2. They where not rendered in bold, they now are.
3. The documentation language was interpreted, it is no longer the case.
If you were relying on the third point via `?none` of `Arg.some`, use the new
`?absent` optional argument of `Arg.info` instead. Besides a new
`Arg.some'` function is added to specify a value for `?none` instead
of a string. Thanks to David Allsopp for the patch (#111).
- Documentation generation use: `…` (U+2026) instead of `...` for
ellipsis. See also UTF-8 manpage support below.
- Documentation generation, improve command synopsis rendering on
commands with few options (i.e. mention them).
- Documentation generation, drop section heading in the output if the section
is empty.
### New `Cmd` module and deprecation of the `Term` evaluation interface
This version of cmdliner deprecates the `Term.eval*` evaluation
functions and `Term.info` information values in favor of the new
`Cmdliner.Cmd` module.
The `Cmd` module generalizes the existing subcommand support to allow
arbitrarily nested subcommands each with its own man page and command
line syntax represented by a `Term.t` value.
The mapping between the old interface and the new one should be rather
straightforward. In particular `Term.info` and `Cmd.info` have exactly
the same semantics and fields and a command value simply pairs a
command information with a term.
However in this transition the following things are changed or added:
* All default values of `Cmd.info` match those of `Term.info` except
for:
* The `?exits` argument which defaults to `Cmd.Exit.defaults`
rather than the empty list.
* The `?man_xrefs` which defaults to the list ``[`Main]`` rather
than the empty list (this means that by default subcommands
at any level automatically cross-reference the main command).
* The `?sdocs` argument which defaults to `Manpage.s_common_options`
rather than `Manpage.s_options`.
* The `Cmd.Exit.some_error` code is added to `Cmd.Exit.defaults`
(which in turn is the default for `Cmd.info` see above). This is an
error code clients can use when they don't want to bother about
having precise exit codes. It is high so that low, meaningful,
codes can later be added without breaking a tool's compatibility. In
particular the convenience evaluation functions `Cmd.eval_result*`
use this code when they evaluate to an error.
* If you relied on `?term_err` defaulting to `1` in the various
`Term.exit*` function, note that the new `Cmd.eval*` function use
`Exit.cli_error` as a default. You may want to explicitly specify
`1` instead if you use `Term.ret` with the `` `Error`` case
or `Term.term_result`.
Finally be aware that if you replace, in an existing tool, an encoding
of subcommands as positional arguments you will effectively break the
command line compatibility of your tool since options can no longer be
specified before the subcommands, i.e. your tool synopsis moves from:
```
tool cmd [OPTION]… SUBCMD [ARG]…
```
to
```
tool cmd SUBCMD [OPTION]… [ARG]…
```
Thanks to Rudi Grinberg for prototyping the feature in #123.
### UTF-8 manpage support
It is now possible to write UTF-8 encoded text in your doc strings and
man pages.
The man page renderer used on `--help` defaults to `mandoc` if
available, then uses `groff` and then defaults to `nroff`. Starting
with `mandoc` catches macOS whose `groff` as of 11.6 still doesn't
support UTF-8 input and struggles to render some Unicode characters.
The invocations were also tweaked to remove the `-P-c` option which
entails that the default pager `less` is now invoked with the `-R` option.
If you install UTF-8 encoded man pages output via `--help=groff`, in
`man` directories bear in mind that these pages will look garbled on
stock macOS (at least until 11.6). One way to work around is to
instruct your users to change the `NROFF` definition in
`/private/etc/man.conf` from:
NROFF /usr/bin/groff -Wall -mtty-char -Tascii -mandoc -c
to:
NROFF /usr/bin/mandoc -Tutf8 -c
Thanks to Antonin Décimo for his knowledge and helping with these
`man`gnificent intricacies (#27).
v1.0.4 2019-06-14 Zagreb
------------------------
- Change the way `Error (_, e)` term evaluation results
are formatted. Instead of treating `e` as text, treat
it as formatted lines.
- Fix 4.08 `Pervasives` deprecation.
- Fix 4.03 String deprecations.
- Fix bootstrap build in absence of dynlink.
- Make the `Makefile` bootstrap build reproducible.
Thanks to Thomas Leonard for the patch.
v1.0.3 2018-11-26 Zagreb
------------------------
- Add `Term.with_used_args`. Thanks to Jeremie Dimino for
the patch.
- Use `Makefile` bootstrap build in opam file.
- Drop ocamlbuild requirement for `Makefile` bootstrap build.
- Drop support for ocaml < 4.03.0
- Dune build support.
v1.0.2 2017-08-07 Zagreb
------------------------
- Don't remove the `Makefile` from the distribution.
v1.0.1 2017-08-03 Zagreb
------------------------
- Add a `Makefile` to build and install cmdliner without `topkg` and
opam `.install` files. Helps bootstraping opam in OS package
managers. Thanks to Hendrik Tews for the patches.
v1.0.0 2017-03-02 La Forclaz (VS)
---------------------------------
**IMPORTANT** The `Arg.converter` type is deprecated in favor of the
`Arg.conv` type. For this release both types are equal but the next
major release will drop the former and make the latter abstract. All
users are kindly requested to migrate to use the new type and **only**
via the new `Arg.[p]conv` and `Arg.conv_{parser,printer}` functions.
- Allow terms to be used more than once in terms without tripping out
documentation generation (#77). Thanks to François Bobot and Gabriel
Radanne.
- Disallow defining the same option (resp. command) name twice via two
different arguments (resp. terms). Raises Invalid_argument, used
to be undefined behaviour (in practice, an arbitrary one would be
ignored).
- Improve converter API (see important message above).
- Add `Term.exit[_status]` and `Term.exit_status_of[_status]_result`.
improves composition with `Pervasives.exit`.
- Add `Term.term_result` and `Term.cli_parse_result` improves composition
with terms evaluating to `result` types.
- Add `Arg.parser_of_kind_of_string`.
- Change semantics of `Arg.pos_left` (see #76 for details).
- Deprecate `Term.man_format` in favor of `Arg.man_format`.
- Reserve the `--cmdliner` option for library use. This is unused for now
but will be in the future.
- Relicense from BSD3 to ISC.
- Safe-string support.
- Build depend on topkg.
### End-user visible changes
The following changes affect the end-user behaviour of all binaries using
cmdliner.
- Required positional arguments. All missing required position
arguments are now reported to the end-user, in the correct
order (#39). Thanks to Dmitrii Kashin for the report.
- Optional arguments. All unknown and ambiguous optional argument
arguments are now reported to the end-user (instead of only
the first one).
- Change default behaviour of `--help[=FMT]` option. `FMT` no longer
defaults to `pager` if unspecified. It defaults to the new value
`auto` which prints the help as `pager` or `plain` whenever the
`TERM` environment variable is `dumb` or undefined (#43). At the API
level this changes the signature of the type `Term.ret` and values
`Term.ret`, `Term.man_format` (deprecated) and `Manpage.print` to add the
new `` `Auto`` case to manual formats. These are now represented by the
`Manpage.format` type rather than inlined polyvars.
### Doc specification improvements and fixes
- Add `?envs` optional argument to `Term.info`. Documents environment
variables that influence a term's evaluation and automatically
integrate them in the manual.
- Add `?exits` optional argument to `Term.info`. Documents exit statuses of
the program. Use `Term.default_exits` if you are using the new `Term.exit`
functions.
- Add `?man_xrefs` optional argument to `Term.info`. Documents
references to other manpages. Automatically formats a `SEE ALSO` section
in the manual.
- Add `Manpage.escape` to escape a string from the documentation markup
language.
- Add `Manpage.s_*` constants for standard man page section names.
- Add a `` `Blocks`` case to `Manpage.blocks` to allow block splicing
(#69). This avoids having to concatenate block lists at the
toplevel of your program.
- `Arg.env_var`, change default environment variable section to the
standard `ENVIRONMENT` manual section rather than `ENVIRONMENT
VARIABLES`. If you previously manually positioned that section in
your man page you will have to change the name. See also next point.
- Fix automatic placement of default environment variable section (#44)
whenever unspecified in the man page.
- Better automatic insertions of man page sections (#73). See the API
docs about manual specification. As a side effect the `NAME` section
can now also be overridden manually.
- Fix repeated environment variable printing for flags (#64). Thanks to
Thomas Gazagnaire for the report.
- Fix rendering of env vars in man pages, bold is standard (#71).
- Fix plain help formatting for commands with empty
description. Thanks to Maciek Starzyk for the patch.
- Fix (implement really) groff man page escaping (#48).
- Request `an` macros directly in the man page via `.mso` this
makes man pages self-describing and avoids having to call `groff` with
the `-man` option.
- Document required optional arguments as such (#82). Thanks to Isaac Hodes
for the report.
### Doc language sanitization
This release tries to bring sanity to the doc language. This may break
the rendering of some of your man pages. Thanks to Gabriel Scherer,
Ivan Gotovchits and Nicolás Ojeda Bär for the feedback.
- It is only allowed to use the variables `$(var)` that are mentioned in
the docs (`$(docv)`, `$(opt)`, etc.) and the markup directives
`$({i,b},text)`. Any other unknown `$(var)` will generate errors
on standard error during documentation generation.
- Markup directives `$({i,b},text)` treat `text` as is, modulo escapes;
see next point.
- Characters `$`, `(`, `)` and `\` can respectively be escaped by `\$`,
`\(`, `\)` and `\\`. Escaping `$` and `\` is mandatory everywhere.
Escaping `)` is mandatory only in markup directives. Escaping `(`
is only here for your symmetric pleasure. Any other sequence of
character starting with a `\` is an illegal sequence.
- Variables `$(mname)` and `$(tname)` are now marked up with bold when
substituted. If you used to write `$(b,$(tname))` this will generate
an error on standard output, since `$` is not escaped in the markup
directive. Simply replace these by `$(tname)`.
v0.9.8 2015-10-11 Cambridge (UK)
--------------------------------
- Bring back support for OCaml 3.12.0
- Support for pre-formatted paragraphs in man pages. This adds a
```Pre`` case to the `Manpage.block` type which can break existing
programs. Thanks to Guillaume Bury for suggesting and help.
- Support for environment variables. If an argument is absent from the
command line, its value can be read and parsed from an environment
variable. This adds an `env` optional argument to the `Arg.info`
function which can break existing programs.
- Support for new variables in option documentation strings. `$(opt)`
can be used to refer to the name of the option being documented and
`$(env)` for the name of the option's the environment variable.
- Deprecate `Term.pure` in favor of `Term.const`.
- Man page generation. Keep undefined variables untouched. Previously
a `$(undef)` would be turned into `undef`.
- Turn a few mysterious and spurious `Not_found` exceptions into
`Invalid_arg`. These can be triggered by client programming errors
(e.g. an unclosed variable in a documentation string).
- Positional arguments. Invoke the printer on the default (absent)
value only if needed. See Optional arguments in the release notes of
v0.9.6.
v0.9.7 2015-02-06 La Forclaz (VS)
---------------------------------
- Build system, don't depend on `ocamlfind`. The package no longer
depends on ocamlfind. Thanks to Louis Gesbert for the patch.
v0.9.6 2014-11-18 La Forclaz (VS)
---------------------------------
- Optional arguments. Invoke the printer on the default (absent) value
only if needed, i.e. if help is shown. Strictly speaking an
interface breaking change – for example if the absent value was lazy
it would be forced on each run. This is no longer the case.
- Parsed command line syntax: allow short flags to be specified
together under a single dash, possibly ending with a short option.
This allows to specify e.g. `tar -xvzf archive.tgz` or `tar
-xvzfarchive.tgz`. Previously this resulted in an error, all the
short flags had to be specified separately. Backward compatible in
the sense that only more command lines are parsed. Thanks to Hugo
Heuzard for the patch.
- End user error message improvements using heuristics and edit
distance search in the optional argument and subcommand name
spaces. Thanks to Hugo Heuzard for the patch.
- Adds `Arg.doc_{quote,alts,alts_enum}`, documentation string
helpers.
- Adds the `Term.eval_peek_opts` function for advanced usage scenarios.
- The function `Arg.enum` now raises `Invalid_argument` if the
enumeration is empty.
- Improves help paging behaviour on Windows. Thanks to Romain Bardou
for the help.
v0.9.5 2014-07-04 Cambridge (UK)
--------------------------------
- Add variance annotation to Term.t. Thanks to Peter Zotov for suggesting.
- Fix section name formatting in plain text output. Thanks to Mikhail
Sobolev for reporting.
v0.9.4 2014-02-09 La Forclaz (VS)
---------------------------------
- Remove temporary files created for paged help. Thanks to Kaustuv Chaudhuri
for the suggestion.
- Avoid linking against `Oo` (was used to get program uuid).
- Check the environment for `$MANPAGER` as well. Thanks to Raphaël Proust
for the patch.
- OPAM friendly workflow and drop OASIS support.
v0.9.3 2013-01-04 La Forclaz (VS)
---------------------------------
- Allow user specified `SYNOPSIS` sections.
v0.9.2 2012-08-05 Lausanne
--------------------------
- OASIS 0.3.0 support.
v0.9.1 2012-03-17 La Forclaz (VS)
---------------------------------
- OASIS support.
- Fixed broken `Arg.pos_right`.
- Variables `$(tname)` and `$(mname)` can be used in a term's man
page to respectively refer to the term's name and the main term
name.
- Support for custom variable substitution in `Manpage.print`.
- Adds `Term.man_format`, to facilitate the definition of help commands.
- Rewrote the examples with a better and consistent style.
Incompatible API changes:
- The signature of `Term.eval` and `Term.eval_choice` changed to make
it more regular: the given term and its info must be tupled together
even for the main term and the tuple order was swapped to make it
consistent with the one used for arguments.
v0.9.0 2011-05-27 Lausanne
--------------------------
- First release.

57
unikernel/duniverse/cmdliner/DEVEL.md Normal file
View file

@ -0,0 +1,57 @@
This project uses (perhaps the development version of) [`b0`] for
development. Consult [b0 occasionally] for quick hints on how to
perform common development tasks.
[`b0`]: https://erratique.ch/software/b0
[b0 occasionally]: https://erratique.ch/software/b0/doc/occasionally.html
# Build system for distribution
The build system used for distribution is in the `Makefile`.
# Changing completion scripts
To test them you can:
source ./src/tool/zsh-completion.sh # zsh
source ./src/tool/bash-completion.sh # bash
This replaces the generic completion function used by tool completion
scripts with the new definition. Trying to complete tools should now
use the new definitions.
If you change completion scripts in [`src/tool`](src/tool) you must invoke:
b0 -- update-cmdliner-data
so that the changes get incorporated into the `cmdliner` tool.
# Testing
Testing is done with `B0_testing` from `b0.std`. The catch is that
`B0_testing` depends on `cmdliner` so we need a build of `b0.std` with
our build of `cmdliner` to link against our test executables.
To do so we do a checkout of `b0`'s repo in `test/b0` (which is ignored
by `git`).
cd test
git clone https://erratique.ch/repos/b0.git
The [`B0.ml`](B0.ml) file of cmdliner includes `test/b0/B0.ml` and the
`default` pack of `B0.ml` is unlocked so that when a test executable
requires `b0.std` it is looked up and built againt the development
version of cmdliner. After that testing remains [as usual].
[as usual]: https://erratique.ch/software/b0/doc/occasionally.html#test
## Manual renderings
Various manual renderings are snapshot tested in the test executables,
mostly in plain text.
The `test_man` test can be invoked with `--test-help[=FMT]` to interactively
test the various `--help[=FMT]` invocations, including paging.
b0 -- test_man --test-help

13
unikernel/duniverse/cmdliner/LICENSE.md Normal file
View file

@ -0,0 +1,13 @@
Copyright (c) 2011 The cmdliner programmers
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

127
unikernel/duniverse/cmdliner/Makefile Normal file
View file

@ -0,0 +1,127 @@
# To be used by system package managers to bootstrap opam. topkg
# cannot be used as it needs opam-installer which is provided by opam
# itself.
# Typical usage:
#
# make all
# make install PREFIX=/usr/local
# make install-doc PREFIX=/usr/local
# Adjust the following on the cli invocation for configuring
-include $(shell ocamlc -where)/Makefile.config
PREFIX=/usr
BINDIR=$(DESTDIR)$(PREFIX)/bin
LIBDIR=$(DESTDIR)$(PREFIX)/lib/ocaml/cmdliner
SHAREDIR=$(DESTDIR)$(PREFIX)/share
DOCDIR=$(SHAREDIR)/doc/cmdliner
MANDIR=$(SHAREDIR)/man
BASHCOMPDIR=$(SHAREDIR)/bash-completion/completions
ZSHCOMPDIR=$(SHAREDIR)/zsh/site-functions
NATIVE=$(shell ocamlopt -version > /dev/null 2>&1 && echo true)
# EXT_LIB by default value of OCaml's Makefile.config
# NATDYNLINK by default value of OCaml's Makefile.config
INSTALL=install
B=_build
BASE=$(B)/src/cmdliner
TOOLBDIR=$(B)/src/tool
TOOL=$(TOOLBDIR)/cmdliner
ifeq ($(NATIVE),true)
BUILD-EXE=build-native-exe
BUILD-TARGETS=build-byte build-native build-native-exe build-completions \
build-man
INSTALL-TARGETS=install-common install-srcs install-byte install-native \
install-exe install-completions
ifeq ($(NATDYNLINK),true)
BUILD-TARGETS += build-native-dynlink
INSTALL-TARGETS += install-native-dynlink
endif
else
BUILD-EXE=build-byte-exe
BUILD-TARGETS=build-byte build-byte-exe build-completions \
build-man
INSTALL-TARGETS=install-common install-srcs install-byte install-exe \
install-completions
endif
all: $(BUILD-TARGETS)
install: $(INSTALL-TARGETS)
clean:
ocaml build.ml clean
build-byte:
ocaml build.ml cma
build-native:
ocaml build.ml cmxa
build-native-dynlink:
ocaml build.ml cmxs
build-byte-exe: build-byte
ocaml build.ml bytexe
build-native-exe: build-native
ocaml build.ml natexe
build-completions: $(BUILD-EXE)
$(TOOL) generic-completion bash > $(TOOLBDIR)/bash-completion.sh
$(TOOL) tool-completion bash cmdliner > $(TOOLBDIR)/bash-cmdliner.sh
$(TOOL) generic-completion zsh > $(TOOLBDIR)/zsh-completion.sh
$(TOOL) tool-completion zsh cmdliner > $(TOOLBDIR)/zsh-cmdliner.sh
build-man: $(BUILD-EXE)
$(TOOL) install tool-manpages $(TOOLBDIR)/cmdliner $(TOOLBDIR)/man
prepare-prefix:
$(INSTALL) -d "$(BINDIR)" "$(LIBDIR)"
install-common: prepare-prefix
$(INSTALL) -m 644 pkg/META $(BASE).cmi "$(LIBDIR)"
$(INSTALL) -m 644 cmdliner.opam "$(LIBDIR)/opam"
install-srcs: prepare-prefix
$(INSTALL) -m 644 $(wildcard $(BASE)*.mli) $(wildcard $(BASE)*.ml) \
$(wildcard $(BASE)*.cmti) $(wildcard $(BASE)*.cmt) "$(LIBDIR)"
install-byte: prepare-prefix
$(INSTALL) -m 644 $(BASE).cma "$(LIBDIR)"
install-native: prepare-prefix
$(INSTALL) -m 644 $(BASE).cmxa $(BASE)$(EXT_LIB) $(wildcard $(BASE)*.cmx) \
"$(LIBDIR)"
install-native-dynlink: prepare-prefix
$(INSTALL) -m 644 $(BASE).cmxs "$(LIBDIR)"
install-exe:
$(INSTALL) -m 755 "$(TOOLBDIR)/cmdliner" "$(BINDIR)/cmdliner"
install-doc:
$(INSTALL) -d "$(MANDIR)/man1"
$(INSTALL) -m 644 $(wildcard $(TOOLBDIR)/man/man1/*.1) "$(MANDIR)/man1"
$(INSTALL) -d "$(DOCDIR)/odoc-pages"
$(INSTALL) -m 644 CHANGES.md LICENSE.md README.md "$(DOCDIR)"
$(INSTALL) -m 644 doc/index.mld doc/cli.mld doc/examples.mld \
doc/tutorial.mld doc/cookbook.mld doc/tool_man.mld "$(DOCDIR)/odoc-pages"
install-completions:
$(INSTALL) -d "$(BASHCOMPDIR)"
$(INSTALL) -m 644 $(TOOLBDIR)/bash-completion.sh \
"$(BASHCOMPDIR)/_cmdliner_generic"
$(INSTALL) -m 644 $(TOOLBDIR)/bash-cmdliner.sh "$(BASHCOMPDIR)/cmdliner"
$(INSTALL) -d "$(ZSHCOMPDIR)"
$(INSTALL) -m 644 $(TOOLBDIR)/zsh-completion.sh \
"$(ZSHCOMPDIR)/_cmdliner_generic"
$(INSTALL) -m 644 $(TOOLBDIR)/zsh-cmdliner.sh "$(ZSHCOMPDIR)/_cmdliner"
.PHONY: all install install-doc clean build-byte build-native \
build-native-dynlink build-byte-exe build-native-exe build-completions \
prepare-prefix install-common install-byte install-native install-dynlink \
install-exe install-completions build-man

43
unikernel/duniverse/cmdliner/README.md Normal file
View file

@ -0,0 +1,43 @@
Cmdliner — Declarative definition of command line interfaces for OCaml
======================================================================
Cmdliner allows the declarative definition of command line interfaces
for OCaml.
It provides a simple and compositional mechanism to convert command
line arguments to OCaml values and pass them to your functions. The
module automatically handles command line completion, syntax errors,
help messages and UNIX man page generation. It supports programs with
single or multiple commands and respects most of the [POSIX] and [GNU]
conventions.
Cmdliner has no dependencies and is distributed under the ISC license.
Homepage: <http://erratique.ch/software/cmdliner>
[POSIX]: http://pubs.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap12.html
[GNU]: http://www.gnu.org/software/libc/manual/html_node/Argument-Syntax.html
## Installation
Cmdliner can be installed with `opam`:
opam install cmdliner
If you don't use `opam` consult the [`opam`](opam) file for build
instructions.
## Documentation
The documentation can be consulted [online] or via `odig doc cmdliner`.
Questions are welcome but better asked on the [OCaml forum] than on the
issue tracker.
[online]: http://erratique.ch/software/cmdliner/doc/
[OCaml forum]: https://discuss.ocaml.org/
## Sample programs
A few examples and blueprints can be found in the
[documentation][online] and in the [test](test/) directory.

3
unikernel/duniverse/cmdliner/_tags Normal file
View file

@ -0,0 +1,3 @@
true : bin_annot, safe_string
<_b0> : -traverse
<src> : include

182
unikernel/duniverse/cmdliner/build.ml Executable file
View file

@ -0,0 +1,182 @@
#!/usr/bin/env ocaml
(* Usage: ocaml build.ml [cma|cmxa|cmxs|clean] *)
let root_dir = Sys.getcwd ()
let root_build_dir = Filename.concat root_dir "_build"
let src_dir = "src"
type unit = Lib | Bin
let unit_dir = function Lib -> "src" | Bin -> "src/tool"
let build_dir u = Filename.concat root_build_dir (unit_dir u)
let base_ocaml_opts =
[ "-g"; "-bin-annot";
"-safe-string"; (* Remove once we require >= 4.06 *) ]
(* Logging *)
let strf = Printf.sprintf
let err fmt = Printf.kfprintf (fun oc -> flush oc; exit 1) stderr fmt
let log fmt = Printf.kfprintf (fun oc -> flush oc) stdout fmt
(* The running joke *)
let rev_cut ~sep s = match String.rindex s sep with
| exception Not_found -> None
| i -> String.(Some (sub s 0 i, sub s (i + 1) (length s - (i + 1))))
let cuts ~sep s =
let rec loop acc = function
| "" -> acc
| s ->
match rev_cut ~sep s with
| None -> s :: acc
| Some (l, r) -> loop (r :: acc) l
in
loop [] s
(* Read, write and collect files *)
let fpath ~dir f = String.concat "" [dir; "/"; f]
let string_of_file f =
let ic = open_in_bin f in
let len = in_channel_length ic in
let buf = Bytes.create len in
really_input ic buf 0 len;
close_in ic;
Bytes.unsafe_to_string buf
let string_to_file f s =
let oc = open_out_bin f in
output_string oc s;
close_out oc
let cp src dst = string_to_file dst (string_of_file src)
let ml_srcs dir =
let add_file dir acc f = match rev_cut ~sep:'.' f with
| Some (m, e) when e = "ml" || e = "mli" -> f :: acc
| Some _ | None -> acc
in
Array.fold_left (add_file dir) [] (Sys.readdir dir)
(* Finding and running commands *)
let find_cmd cmds =
let test, null = match Sys.win32 with
| true -> "where", " NUL"
| false -> "command -v", "/dev/null"
in
let cmd c = Sys.command (strf "%s %s 1>%s 2>%s" test c null null) = 0 in
try Some (List.find cmd cmds) with Not_found -> None
let err_cmd exit cmd = err "exited with %d: %s\n" exit cmd
let quote_cmd = match Sys.win32 with
| false -> fun cmd -> cmd
| true -> fun cmd -> strf "\"%s\"" cmd
let run_cmd args =
let cmd = String.concat " " (List.map Filename.quote args) in
(* log "[EXEC] %s\n" cmd; *)
let exit = Sys.command (quote_cmd cmd) in
if exit = 0 then () else err_cmd exit cmd
let read_cmd args =
let stdout = Filename.temp_file (Filename.basename Sys.argv.(0)) "b00t" in
at_exit (fun () -> try ignore (Sys.remove stdout) with _ -> ());
let cmd = String.concat " " (List.map Filename.quote args) in
let cmd = quote_cmd @@ strf "%s 1>%s" cmd (Filename.quote stdout) in
let exit = Sys.command cmd in
if exit = 0 then string_of_file stdout else err_cmd exit cmd
(* Create and delete directories *)
let rec mkdir dir =
let parent = Filename.dirname dir in
if String.equal dir parent then ()
else mkdir (Filename.dirname dir);
try match Sys.file_exists dir with
| true -> ()
| false -> run_cmd ["mkdir"; dir]
with
| Sys_error e -> err "%s: %s" dir e
let rec rmdir dir =
try match Sys.file_exists dir with
| false -> ()
| true ->
let rm f =
let p = fpath ~dir f in
if Sys.is_directory p
then rmdir p
else Sys.remove (fpath ~dir f)
in
Array.iter rm (Sys.readdir dir);
run_cmd ["rmdir"; dir]
with
| Sys_error e -> err "%s: %s" dir e
(* Lookup OCaml compilers and ocamldep *)
let really_find_cmd alts = match find_cmd alts with
| Some cmd -> cmd
| None -> err "No %s found in PATH\n" (List.hd @@ List.rev alts)
let ocamlc () = really_find_cmd ["ocamlc.opt"; "ocamlc"]
let ocamlopt () = really_find_cmd ["ocamlopt.opt"; "ocamlopt"]
let ocamldep () = really_find_cmd ["ocamldep.opt"; "ocamldep"]
(* Build *)
let sort_srcs srcs =
let srcs = List.sort String.compare srcs in
read_cmd (ocamldep () :: "-slash" :: "-sort" :: srcs)
|> String.trim |> cuts ~sep:' '
let common srcs = base_ocaml_opts @ sort_srcs srcs
let exe ar src =
let lib = build_dir Lib in
["-I"; lib; ar] @ common src
let build_natexe srcs =
run_cmd ([ocamlopt ()] @ exe "cmdliner.cmxa" srcs @ ["-o"; "cmdliner"])
let build_bytexe srcs =
run_cmd ([ocamlc ()] @ exe "cmdliner.cma" srcs @ ["-o"; "cmdliner"])
let build_cma srcs =
run_cmd ([ocamlc ()] @ common srcs @ ["-a"; "-o"; "cmdliner.cma"])
let build_cmxa srcs =
run_cmd ([ocamlopt ()] @ common srcs @ ["-a"; "-o"; "cmdliner.cmxa"])
let build_cmxs srcs =
run_cmd ([ocamlopt ()] @ common srcs @ ["-shared"; "-o"; "cmdliner.cmxs"])
let clean () = rmdir root_build_dir
let in_build_dir u f =
let src_dir = unit_dir u in
let build_dir = build_dir u in
let srcs = ml_srcs src_dir in
let cp src = cp (fpath ~dir:src_dir src) (fpath ~dir:build_dir src) in
mkdir build_dir;
List.iter cp srcs;
Sys.chdir build_dir; f srcs; Sys.chdir root_dir
let main () = match Array.to_list Sys.argv with
| _ :: [ "natexe" ] -> in_build_dir Bin build_natexe
| _ :: [ "bytexe" ] -> in_build_dir Bin build_bytexe
| _ :: [ "cma" ] -> in_build_dir Lib build_cma
| _ :: [ "cmxa" ] -> in_build_dir Lib build_cmxa
| _ :: [ "cmxs" ] -> in_build_dir Lib build_cmxs
| _ :: [ "clean" ] -> clean ()
| [] | [_] -> err "Missing argument: cma, cmxa, cmxs or clean\n";
| cmd :: args ->
err "%s: Unknown argument(s): %s\n" cmd @@ String.concat " " args
let () = main ()

34
unikernel/duniverse/cmdliner/cmdliner.opam Normal file
View file

@ -0,0 +1,34 @@
version: "2.0.0+dune"
opam-version: "2.0"
name: "cmdliner"
synopsis: "Declarative definition of command line interfaces for OCaml"
description: """\
Cmdliner allows the declarative definition of command line interfaces
for OCaml.
It provides a simple and compositional mechanism to convert command
line arguments to OCaml values and pass them to your functions. The
module automatically handles command line completion, syntax errors,
help messages and UNIX man page generation. It supports programs with
single or multiple commands and respects most of the [POSIX] and [GNU]
conventions.
Cmdliner has no dependencies and is distributed under the ISC license.
Homepage: <http://erratique.ch/software/cmdliner>
[POSIX]: http://pubs.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap12.html
[GNU]: http://www.gnu.org/software/libc/manual/html_node/Argument-Syntax.html"""
maintainer: "Daniel Bünzli <daniel.buenzl i@erratique.ch>"
authors: "The cmdliner programmers"
license: "ISC"
tags: ["cli" "system" "declarative" "org:erratique"]
homepage: "https://github.com/dune-universe/cmdliner"
bug-reports: "https://github.com/dbuenzli/cmdliner/issues"
depends: [
"dune"
"ocaml" {>= "4.08.0"}
]
build: [ "dune" "build" "-p" name "-j" jobs ]
dev-repo: "git+https://github.com/dune-universe/cmdliner.git"
x-maintenance-intent: ["(latest)"]

484
unikernel/duniverse/cmdliner/doc/cli.mld Normal file
View file

@ -0,0 +1,484 @@
{0:cmdline Command line interface}
This manual describes how your tool ends up interacting
with shells when you use Cmdliner.
{1:invocation Tool invocation}
For tools evaluating a command without subcommands the most general
form of invocation is:
{v
tool [OPTION]… [ARG]…
v}
The tool automatically reponds to the [--help] option by printing
{{!help}the help}. If a version string is provided in the
{{!Cmdliner.Cmd.val-info}command information}, it also automatically
responds to the [--version] option by printing this string on standard
output.
Command line arguments are either {{!optargs}{e optional}} or
{{!posargs}{e positional}}. Both can be freely interleaved but since
[Cmdliner] accepts many optional forms this may result in
ambiguities. The special {{!posargs} token [--]} can be used to
resolve them: anything that follows it is treated as a positional
argument.
Tools evaluating commands with subcommands have this form of invocation
{v
tool [COMMAND]… [OPTION]… [ARG]…
v}
Commands automatically respond to the [--help] option by printing
{{!help}their help}. The sequence of [COMMAND] strings must be the first
strings following the tool name – as soon as an optional argument is
seen the search for a subcommand stops.
{1:args Arguments}
{2:optargs Optional arguments}
An optional argument is specified on the command line by a {e name}
possibly followed by a {e value}.
The name of an option can be short or long.
{ul
{- A {e short} name is a dash followed by a single alphanumeric
character: [-h], [-q], [-I].}
{- A {e long} name is two dashes followed by alphanumeric
characters and dashes: [--help], [--silent], [--ignore-case].}}
More than one name may refer to the same optional argument. For
example in a given program the names [-q], [--quiet] and [--silent]
may all stand for the same boolean argument indicating the program to
be quiet.
The value of an option can be specified in three different ways.
{ul
{- As the next token on the command line: [-o a.out], [--output a.out].}
{- Glued to a short name: [-oa.out].}
{- Glued to a long name after an equal character: [--output=a.out].}}
Glued forms are especially useful if the value itself starts with a
dash as is the case for negative numbers, [--min=-10].
An optional argument without a value is either a {e flag} (see
{!Cmdliner.Arg.flag}, {!Cmdliner.Arg.vflag}) or an optional argument with
an optional value (see the [~vopt] argument of {!Cmdliner.Arg.opt}).
Short flags can be grouped together to share a single dash and the
group can end with a short option. For example assuming [-v] and
[-x] are flags and [-f] is a short option:
{ul
{- [-vx] will be parsed as [-v -x].}
{- [-vxfopt] will be parsed as [-v -x -fopt].}
{- [-vxf opt] will be parsed as [-v -x -fopt].}
{- [-fvx] will be parsed as [-f=vx].}}
{2:posargs Positional arguments}
Positional arguments are tokens on the command line that are not
option names and are not the value of an optional argument. They are
numbered from left to right starting with zero.
Since positional arguments may be mistaken as the optional value of an
optional argument or they may need to look like option names, anything
that follows the special token ["--"] on the command line is
considered to be a positional argument:
{v
tool --option -- but --now we -are --all positional --argu=ments
v}
{2:constraints Constraints on option names}
Using the cmdliner library puts the following constraints on your
command line interface:
{ul
{- The option names [--cmdliner] and [--__complete] are reserved by the
library.}
{- The option name [--help], (and [--version] if you specify a version
string) is reserved by the library. Using it as a term or option
name may result in undefined behaviour.}
{- Defining the same option or command name via two different
arguments or terms is illegal and raises [Invalid_argument].}}
{1:envlookup Environment variables}
Non-required command line arguments can be backed up by an environment
variable. If the argument is absent from the command line and
the environment variable is defined, its value is parsed using the
argument converter and defines the value of the argument.
For {!Cmdliner.Arg.flag} and {!Cmdliner.Arg.flag_all} that do not have an
argument converter a boolean is parsed from the lowercased variable value
as follows:
{ul
{- [""], ["false"], ["no"], ["n"] or ["0"] is [false].}
{- ["true"], ["yes"], ["y"] or ["1"] is [true].}
{- Any other string is an error.}}
Note that environment variables are not supported for
{!Cmdliner.Arg.vflag} and {!Cmdliner.Arg.vflag_all}.
{1:help Help and man pages}
Help and man pages are are generated when you call your tool or a subcommand
with [--help]. By default, if the [TERM] environment variable
is not [dumb] or unset, the tool tries to {{!paging}page} the manual
so that you can directly search it. Otherwise it outputs the manual
as plain text.
Alternative help formats can be specified with the optional argument
of [--help], see your own [tool --help] for more information.
{@sh[
tool --help
tool cmd --help
tool --help=groff > tool.1
]}
{2:paging Paging}
The pager is selected by looking up, in order:
{ol
{- The [MANPAGER] variable.}
{- The [PAGER] variable.}
{- The tool [less].}
{- The tool [more].}}
Regardless of the pager, it is invoked with [LESS=FRX] set in the
environment unless, the [LESS] environment variable is set in your
environment.
{2:install_tool_manpages Install}
The manpages of a tool and its subcommands can be installed to a root
[man] directory [$MANDIR] by invoking:
{@shell[
cmdliner install tool-manpages thetool $MANDIR
]}
This looks up [thetool] in the [PATH]. Use an explicit file path like
[./thetool] to directly specify an executable.
If you are also {{!install_tool_completion}installing completions}
rather use the [install tool-support] command, see this
{{!page-cookbook.tip_tool_support}cookbook tip} which also has
instructions on how to install if you are using [opam].
{1:cli_completion Command line completion}
Cmdliner programs automatically get support for shell command line
completion.
The completion process happens via a {{!completion_protocol}protocol}
which is interpreted by generic shell completion scripts that are
installed by the library. For now the [zsh] and [bash] shells are
supported.
Tool developers can easily {{!install_tool_completion}install}
completion definitions that invoke these completion scripts. Tool
end-users need to {{!user_configuration}make sure} these definitions are
looked up by their shell.
{2:user_configuration End-user configuration}
If you are the user of a cmdliner based tool, the following
shell-dependent steps need to be performed in order to benefit from
command line completion.
{3:user_zsh For [zsh]}
The [FPATH] environment variable must be setup to include the
directory where the generic cmdliner completion function is
{{!install_completion} installed} {b before} properly initializing the
completion system.
For example, {{:https://github.com/ocaml/opam/issues/6427}for now}, if
you are using [opam]. You should add something like this to your
[.zshrc]:
{@sh[
FPATH="$(opam var share)/zsh/site-functions:${FPATH}"
autoload -Uz compinit
compinit -u
]}
Also make sure this {b happens before} [opam]'s [zsh] init script
inclusion, see {{:https://github.com/ocaml/opam/issues/6428}this
issue}. Note that these instruction do not react dynamically
to [opam] switches changes so you may see odd completion behaviours
when you do so, see this {{:https://github.com/ocaml/opam/issues/6427}this
opam issue}.
After this, to test everything is right, check that the [_cmdliner_generic]
function can be looked by invoking it (this will result in an error).
{@sh[
> autoload _cmdliner_generic
> _cmdliner_generic
_cmdliner_generic:1: words: assignment to invalid subscript range
]}
If the function cannnot be found make sure the [cmdliner] library is
installed, that the generic scripts were
{{!install_generic_completion}installed} and that the
[_cmdliner_generic] file can be found in one of the directories
mentioned in the [FPATH] variable.
With this setup, if you are using a cmdliner based tool named
[thetool] that did not {{!install_tool_completion}install} a completion
definition. You can always do it yourself by invoking:
{@sh[
autoload _cmdliner_generic
compdef _cmdliner_generic thetool
]}
{3:user_bash For [bash]}
These instructions assume that you have
{{:https://repology.org/project/bash-completion/versions}[bash-completion]}
installed and setup in some way in your [.bashrc].
The [XDG_DATA_DIRS] environment variable must be setup to include the
[share] directory where the generic cmdliner completion function is
{{!install_completion}installed}.
For example, {{:https://github.com/ocaml/opam/issues/6427}for now}, if
you are using [opam]. You should add something like this to your
[.bashrc]:
{@sh[
XDG_DATA_DIRS="$(opam var share):${XDG_DATA_DIRS}"
]}
Note that these instruction do not react dynamically to [opam]
switches changes so you may see odd completion behaviours when you do
so, see this {{:https://github.com/ocaml/opam/issues/6427}this opam
issue}.
After this, to test everything is right, check that the [_cmdliner_generic]
function can be looked up:
{@sh[
> _completion_loader _cmdliner_generic
> declare -F _cmdliner_generic &>/dev/null && echo "Found" || echo "Not found"
Found!
]}
If the function cannot be found make sure the [cmdliner] library is
installed, that the generic scripts were
{{!install_generic_completion}installed} and that the
[_cmdliner_generic] file can be looked up by [_completion_loader].
With this setup, if you are using a cmdliner based tool named
[thetool] that did not {{!install_tool_completion}install} a completion
definition. You can always do it yourself by invoking:
{@sh[
_completion_loader _cmdliner_generic
complete -F _cmdliner_generic thetool
]}
{b Note.} {{:https://github.com/scop/bash-completion/commit/9efc596735c4509001178f0cf28e02f66d1f7703}It seems} [_completion_loader] was deprecated in
bash-completion [2.12] in favour of [_comp_load] but many distributions
are on [< 2.12] and in [2.12] [_completion_loader] simply calls
[_comp_load].
{2:install_completion Install}
Completion scripts need to be installed in subdirectories of a
{{:https://refspecs.linuxfoundation.org/FHS_3.0/fhs/ch04s11.html}[share]}
directory which we denote by the [$SHAREDIR] variable below. In a
package installation script this variable is typically defined by:
{@sh[
SHAREDIR="$DESTDIR/$PREFIX/share"
]}
The final destination directory in [share] depends on the shell:
{ul
{- For [zsh] it is [$SHAREDIR/zsh/site-functions]}
{- For [bash] it is [$SHAREDIR/bash-completion/completions]}}
If that is unsatisfying you can output the completion scripts directly
where you want with the [cmdliner generic-completion] and
[cmdliner tool-completion] commands.
{3:install_generic_completion Generic completion scripts}
The generic completion scripts must be installed by the
[cmdliner] library. They should not be part of your tool install. If
they are not installed you can inspect and install them with the
following invocations, invoke with [--help] for more information.
{@sh[
cmdliner generic-completion zsh # Output generic zsh script on stdout
cmdliner install generic-completion $SHAREDIR # All shells
cmdliner install generic-completion --shell zsh $SHAREDIR # Only zsh
]}
Directories are created as needed. Use option [--dry-run] to see which
paths would be written by an [install] invocation.
{3:install_tool_completion Tool completion scripts}
If your tool named [thetool] uses Cmdliner you should install completion
definitions for them. They rely on the {{!install_generic_completion}generic
scripts} to be installed. These tool specific scripts can be inspected
and installed via these invocations:
{@sh[
cmdliner tool-completion zsh thetool # Output tool zsh script on stdout.
cmdliner install tool-completion thetool $SHAREDIR # All shells
cmdliner install tool-completion --shell zsh thetool $SHAREDIR # Only zsh
]}
Directories are created as needed. Use option [--dry-run] to see which
paths would be written by an [install] invocation.
If you are also {{!install_tool_manpages}installing manpages} rather
use the [install tool-support] command, see this
{{!page-cookbook.tip_tool_support}cookbook tip} which also has
instructions on how to install if you are using [opam].
{2:completion_protocol Completion protocol}
There is no standard that allows tools and shells to interact to
perform shell command line completion. Completion is supposed to
happen through idiosyncratic, ad-hoc, obscure and brain damaging
shell-specific completion scripts.
To alleviate this, Cmdliner defines one generic script per shell and
interacts with it using the protocol described below. The protocol can
be used to implement generic completion scripts for other shells. The
protocol is versioned but can change even between minor versions of
Cmdliner. Generic scripts for popular shells can be inspected via
the [cmdliner generic-completion] command.
The protocol betwen the shell completion {e script} and a
cmdliner based {e tool} is as follows:
{ol
{- When completion is requested the script invokes the tool with a
modified command line:
{ul
{- The first argument to the tool ([Sys.argv.(1)]) must be the
option [--__complete].}
{- The (possibly empty) argument [ARG] on which the completion is
requested must be replaced by {e exactly} [--__complete=ARG]. Note
that this can happen after the [--] token, this is the reason
why we have an explicit [--__complete] argument in [Sys.argv.(1)]:
it indicates the command line parser must operate in a special mode.}}}
{- The tool responds by writing on standard output a list of
completion directives which match the [completions] rule of the grammar
given below.}
{- The script interprets the completion directives according
to the given semantics below so that the shell can display the
completions. The script is free to ignore directives
or data that it is unable to present.}}
The following ABNF grammar is described using the notations of
{{:https://www.rfc-editor.org/rfc/rfc5234}RFC 5234} and
{{:https://www.rfc-editor.org/rfc/rfc7405}RFC 7405}. A few constraints
are not expressed by the grammar:
{ul
{- Except in the [completion] rule, the byte stream may contain ANSI escape
sequences introduced by the byte [0x1B].}
{- After stripping the ANSI escape sequences, the resulting byte stream must
be valid UTF-8 text.}}
{@abnf[
completions = version nl directives
version = "1"
directives = *(directive nl)
directive = message / group / %s"files" / %s"dirs" / %"restart"
message = %s"message" nl text nl %s"message-end"
group = %s"group" nl group_name nl *item
group_name = *pchar
item = %s"item" nl completion nl item_doc nl %s"item-end"
completion = *pchar
item_doc = text
text = *(pchar / nl)
nl = %0A
pchar = %20-%7E / %8A-%FF
]}
The semantics of directives is as follows:
{ul
{- A [message] directive defines a message to be reported to the user.
It is multi-line ANSI styled text which cannot have a line that is
exactly made of the text [message-end] as it is used to signal the
end of the message. Messages should be reported in the order they
are received.}
{- A [group] directive defines an informational [group_name] followed
by a possibly empty list of completion items that are part of the
group. An item provides a [completion] value, this is a string that
defines what the requested [ARG] value can be replaced with. It is
followed by an [item_doc], multi-line ANSI styled text which cannot
have a line that is exactly made of the text [item-end] as it is
used to signal the end of the item.}
{- A [file] directive indicates that the script should add existing
files staring with [ARG] to completion values.}
{- A [dir] directive indicates that the script should add existing
directories starting with [ARG] to completion values.}
{- A [restart] directive indicates that the script should restart
shell completion as if the command line was starting after the leftmost
[--] disambiguation token. The directive never gets emited if
there is no [--] on the command line.}}
You can easily inspect the completions of any cmdliner based tool by
invoking it like the protocol suggests. For example for the [cmdliner]
tool itself:
{@shell[
cmdliner --__complete --__complete=
]}
{1:error_message_styling Error message ANSI styling}
Since Cmdliner 2.0 error messages printed on [stderr] use styled text
with ANSI escapes unless one of the following conditions is met:
{ul
{- The [NO_COLOR] environment variable is set and different
from the empty string. Yes, even if you have [NO_COLOR=false], that's
what the particularly dumb {:https://no-color.org} standard says.}
{- The [TERM] environment variable is [dumb].}
{- The [TERM] environment variable is unset and {!Sys.backend_type} is
not [Other "js_of_ocaml"]. Yes, browser consoles support
ANSI escapes. Yes, you can run Cmdliner in your browser.}}
{1:legacy_prefix_specification Legacy prefix specification}
Before Cmdliner 2.0, command names, long option names and
{!Cmdliner.Arg.enum} values could be specified by a prefix as long as
the prefix was not ambiguous.
This turned out to be a mistake. It makes the user experience of the
tool unstable as it evolves: former user established shortcuts or
invocations in scripts may be broken by new command, option and
enumerant additions.
Therefore this behaviour was unconditionally removed in Cmdliner
2.0. If you happen to have scripts that rely on it, you can invoke
them with [CMDLINER_LEGACY_PREFIXES=true] set in the environment to
recover the old behaviour. {b However the scripts should be fixed: this
escape hatch will be removed in the future.}
The [CMDLINER_LEGACY_PREFIX=true] escape hatch should not be used for
interactive tool interaction. In particular the behaviour of Cmdliner
completion support under this setting is undefined.

720
unikernel/duniverse/cmdliner/doc/cookbook.mld Normal file
View file

@ -0,0 +1,720 @@
{0 [Cmdliner] cookbook}
A few recipes and starting {{!blueprints}blueprints} to describe your
command lines with {!Cmdliner}.
{b Note.} Some of the code snippets here assume they are done after:
{[
open Cmdliner
open Cmdliner.Term.Syntax
]}
{1:tips Tips and pitfalls}
Command line interfaces are a rather crude and inexpressive user
interaction medium. It is tempting to try to be nice to users in
various ways but this often backfires in confusing context sensitive
behaviours. Here are a few tips and Cmdliner features you {b should
rather not use}.
{2:tip_avoid_default_command Avoid default commands in groups}
Command {{!Cmdliner.Cmd.group}groups} can have a default command, that
is be of the form [tool [CMD]]. Except perhaps at the top level of
your tool, it's better to avoid them. They increase command line
parsing ambiguities.
In particular if the default command has positional arguments, users
are forced to use the {{!cli.posargs}disambiguation token [--]} to
specify them so that they can be distinguished from command
names. For example:
{@sh[
tool -- file …
]}
One thing that is acceptable is to have a default command that simply
{{!cmds_show_docs}shows documentation} for the group of subcommands as
this not interfere with tool operation.
{2:tip_avoid_default_option_values Avoid default option values}
Optional arguments {{!Cmdliner.Arg.opt}with values} can have a default
value, that is be of the form [--opt[=VALUE]]. In general it is better
to avoid them as they lead to context sensitive command lines
specifications and surprises when users refine invocations. For examples
suppose you have the synopsis
{@sh[
tool --opt[=VALUE] [FILE]
]}
Trying to refine the following invocation to add a [FILE] parameter is
error prone and painful:
{@sh[
tool --opt
]}
There is more than one way but the easiest way is to specify:
{@sh[
tool --opt -- FILE
]}
which is not obvious unless you have [tool]'s cli hard wired in your
brain. This would have been a careless refinement if [--opt] did not
have a default option value.
{2:tip_avoid_required_opt Avoid required optional arguments}
Cmdliner allows to define required optional arguments. Avoid doing
this, it's a contradiction in the terms. In command line interfaces
optional arguments are defined to be… optional, not doing so is
surprising for your users. Use required positional arguments if
arguments are required by your command invocation.
Required optional arguments can be useful though if your tool is not
meant to be invoked manually but rather through scripts and has many
required arguments. In this case they become a form of labelled
arguments which can make invocations easier to understand.
{2:tip_avoid_manpages Avoid making manpages your main documentation}
Unless your tool is very simple, avoid making manpages the main
documentation medium of your tool. The medium is rather limited and
even though you can convert them to HTML, its cross references
capabilities are rather limited which makes discussing your tool
online more difficult.
Keep information in manpages to the minimum needed to operate your
tool without having to leave the terminal too much and defer reference
manuals, conceptual information and tutorials to a more evolved medium
like HTML.
{2:tip_migrating Migrating from other conventions}
If you are porting your command line parsing to [Cmdliner] and that
you have conventions that clash with [Cmdliner]'s ones but you need to
preserve backward compatibility, one way of proceeding is to
pre-process {!Sys.argv} into a new array of the right shape before
giving it to command {{!Cmdliner.Cmd.section-eval}evaluation
functions} via the [?argv] optional argument.
These are two common cases:
{ul
{- Long option names with a single dash like [-warn-error]. In this
case simply prefix an additional [-] to these arguments when they
occur in {!Sys.argv} before the [--] argument; after it, all arguments are
positional and to be treated literally.}
{- Long option names with a single letter like [--X]. In this
case simply chop the first [-] to make it a short option when they
occur in {!Sys.argv} before the [--] argument; after it all arguments are
positional and to be treated literally.}}
{2:tip_src_structure Source code structure}
In general Cmdliner wants you to see your tools as regular OCaml functions
that you make available to the shell. This means adopting the following
source structure:
{[
(* Implementation of your command. Except for exit codes does not deal with
command line interface related matters and is independent from
Cmdliner. *)
let exit_ok = 0
let tool … = …; exit_ok
(* Command line interface. Adds metadata to your [tool] function arguments
so that they can be parsed from the command line and documented. *)
open Cmdliner
open Cmdliner.Term.Syntax
let cmd = … (* Has a term that invokes [tool] *)
let main () = Cmd.eval' cmd
let () = if !Sys.interactive then () else exit (main ())
]}
In particular it is good for your readers' understanding that your
program has a single point where it {!Stdlib.exit}s. This structure is
also useful for playing with your program in the OCaml toplevel
(REPL), you can invoke its [main] function without having the risk of it
[exit]ing the toplevel.
If your tool named [tool] is growing into multiple commands which
have a lot of definitions it is advised to:
{ul
{- Gather command line definition commonalities such as argument
converters or common options in a module called [Tool_cli].}
{- Define each command named [name] in a separate module [Cmd_name] which
exports its command as a [val cmd : int Cmd.t] value.}
{- Gather the commands with {!Cmdliner.Cmd.group} in a source file
called [tool_main.ml].}}
For an hypothetic tool named [tool] with commands [import], [serve]
and [user], this leads to the following set of files:
{[
cmd_import.ml cmd_serve.ml cmd_user.ml tool_cli.ml tool_main.ml
cmd_import.mli cmd_serve.mli cmd_user.mli tool_cli.mli
]}
The [.mli] files simply export commands:
{[
val cmd : int Cmdliner.Cmd.t
]}
And the [tool_main.ml] gathers them with a {!Cmdliner.Cmd.group}:
{[
let cmd =
let default = Term.(ret (const (`Help (`Auto, None)))) (* show help *) in
Cmd.group (Cmd.info "tool") ~default @@
[Cmd_import.cmd; Cmd_serve.cmd; Cmd_user.cmd]
let main () = Cmd.value' cmd
let () = if !Sys.interactive then () else exit (main ())
]}
{2:tip_tool_support Installing completions and manpages}
The [cmdliner] tool can be used to install completion scripts and
manpages for you tool and its subcommands by using the dedicated
{{!page-cli.install_tool_completion}[install tool-completion]} and
{{!page-cli.install_tool_manpages}[install tool-manpages]} subcommands.
To install both directly (and possibly other support files in the future)
it is more concise to use the [install
tool-support] command. Invoke with [--help] for more information.
{3:tip_tool_support_with_opam With [opam]}
If you are installing your package with [opam] for a tool named [tool]
located in the build at the path [$BUILD/tool], you can add the following
instruction after your build instructions in the [build:] field of
your [opam] file (also works if your build system is not using a
[.install] file).
{@sh[
build: [
[ … ] # Your regular build instructions
["cmdliner" "install" "tool-support"
"--update-opam-install=%{_:name}%.install"
"$BUILD/tool" "_build/cmdliner-install"]]
]}
You need to specify the path to the built executable, as it cannot be
looked up in the [PATH] yet. Also more than one tool can be specified
in a single invocation and there is a syntax for specifying the actual
tool name if it is renamed on install; see [--help] for more
details.
If [cmdliner] is only an optional dependency of your package use the
opam filter [{cmdliner:installed}] after the closing bracket of the command
invocation.
{3:tip_tool_support_with_opam_dune With [opam] and [dune]}
First make sure your understand the
{{!tip_tool_support_with_opam}above basic instructions} for [opam].
You then
{{:https://dune.readthedocs.io/en/stable/reference/packages.html#generating-opam-files}need to figure out} how to add the [cmdliner install] instruction to the [build:]
field of the opam file after your [dune] build instructions. For a tool named
[tool] the result should eventually look this:
{@sh[
build: [
[ … ] # Your regular dune build instructions
["cmdliner" "install" "tool-support"
"--update-opam-install=%{_:name}%.install"
"_build/default/install/bin/tool" {os != "win32"}
"_build/default/install/bin/tool.exe" {os = "win32"}
"_build/cmdliner-install"]]
]}
{1:conventions Conventions}
By simply using Cmdliner you are already abiding to a great deal
of command line interface conventions. Here are a few other ones that
are not necessarily enforced by the library but that are good to
adopt for your users.
{2:conv_use_dash Use ["-"] to specify [stdio] in file path arguments}
Whenever a command line argument specifies a file path to read or
write you should let the user specify [-] to denote standard in or
standard out, if possible. If you worry about a file sporting this
name, note that the user can always specify it using [./-] for
the argument.
Very often tools default to [stdin] or [stdout] when a file
input or output is unspecified, here is typical argument definitions
to support these conventions:
{[
let infile =
let doc = "$(docv) is the file to read from. Use $(b,-) for $(b,stdin)" in
Arg.(value & opt string "-" & info ["i", "input-file"] ~doc ~docv:"FILE")
let outfile =
let doc = "$(docv) is the file to write to. Use $(b,-) for $(b,stdout)" in
Arg.(value & opt string "-" & info ["o", "output-file"] ~doc ~docv:"FILE")
]}
Here is {!Stdlib} based code to read to a string a file or standard
input if [-] is specified:
{[
let read_file file =
let read file ic = try Ok (In_channel.input_all ic) with
| Sys_error e -> Error (Printf.sprintf "%s: %s" file e)
in
let binary_stdin () = In_channel.set_binary_mode In_channel.stdin true in
try match file with
| "-" -> binary_stdin (); read file In_channel.stdin
| file -> In_channel.with_open_bin file (read file)
with Sys_error e -> Error e
]}
Here is {!Stdlib} based code to write a string to a file or standard output
if [-] is specified:
{[
let write_file file s =
let write file s oc = try Ok (Out_channel.output_string oc s) with
| Sys_error e -> Error (Printf.sprintf "%s: %s" file e)
in
let binary_stdout () = Out_channel.(set_binary_mode stdout true) in
try match file with
| "-" -> binary_stdout (); write file s Out_channel.stdout
| file -> Out_channel.with_open_bin file (write file s)
with Sys_error e -> Error e
]}
{2:conv_env_defaults Environment variables as default modifiers}
Cmdliner has support to back values defined by arguments with
environment variables. The value specified via an environment variable
should never take over an argument specified explicitely on the
command line. The environment variable should be seen as providing
the default value when the argument is absent.
This is exactly what Cmdliner's support for environment variables does,
see {!env_args}
{1:args Arguments}
{2:args_positional How do I define a positional argument?}
Positional arguments are extracted from the command line using
{{!Cmdliner.Arg.posargs}these combinators} which use zero-based
indexing. The following example extracts the first argument and if
the argument is absent from the command line it evaluates
to ["Revolt!"].
{[
let msg =
let doc = "$(docv) is the message to utter." and docv = "MSG" in
Arg.(value & pos 0 string "Revolt!" & info [] ~doc ~docv)
]}
{2:args_optional How do I define an optional argument?}
Optional arguments are extracted from the command line using
{{!Cmdliner.Arg.optargs}these combinators}. The actual option
name is defined in the {!Cmdliner.Arg.val-info} structure without
dashes. One character strings define short options, others long
options (see the {{!page-cli.optargs}parsed syntax}).
The following defines the [-l] and [--loud] options. This is a simple
command line argument without a value also known as a command line {e
flag}. The term [loud] evaluates to [false] when the argument is
absent on the command line and [true] otherwise.
{[
let loud =
let doc = "Say the message loudly." in
Arg.(value & flag & info ["l"; "loud"] ~doc)
]}
The following defines the [-m] and [--message] options. The term [msg] evalutes
to ["Revolt!"] when the option is absent on the command line.
{[
let msg =
let doc = "$(docv) is the message to utter." and docv = "MSG" in
Arg.(value & opt string "Revolt!" & info ["m"; "message"] ~doc ~docv)
]}
{2:args_required How do I define a required argument?}
Some of the constraints on the presence of arguments occur when the
specification of arguments is {{!Cmdliner.Arg.argterms}converted} to
terms. The following says that the first positional argument is required:
{[
let msg =
let msg = "$(docv) is the message to utter." and docv = "MSG" in
Arg.(required & pos 0 (some string) None & info [] ~absent ~doc ~docv)
]}
The value [msg] ends up being a term of type [string]. If the argument
is not provided, Cmdliner will automatically bail out during evaluation
with an error message.
Note that while it is possible to define required positional argument
it is {{!tip_avoid_required_opt}discouraged}.
{2:args_detect_absent How can I know if an argument was absent?}
Most {{!Cmdliner.Arg.posargs}positional} and
{{!Cmdliner.Arg.optargs}optional} arguments have a default value. You
can use a [None] for the default argument and the {!Cmdliner.Arg.some} or
{!Cmdliner.Arg.some'} combinators on your argument converter which simply
wrap its result in a [Some].
{[
let msg =
let msg = "$(docv) is the message to utter." in
let absent = "Random quote." in
Arg.(value & pos 0 (some string) None & info [] ~absent ~doc ~docv:"MSG")
]}
There is more than one way to document the value when it is
absent. See {!args_absent_doc}
{2:args_absent_doc How do I document absent argument behaviours?}
There are three ways to document the behaviour when an argument is
unspecified on the command line.
{ul
{- If you specify a default value in the argument combinator, this value
gets printed in bold using the {{!Cmdliner.Arg.conv_printer}printer}
of the converter.}
{- If you are using the {!Cmdliner.Arg.some'} and {!Cmdliner.Arg.some}
there is an optional [none] argument that allows you to specify
the default value. If you can exhibit this value at definition
point use {!Cmdliner.Arg.some'}, the underlying converter's
{{!Cmdliner.Arg.conv_printer}printer} will be used. If not
you can specify it as a string rendered in bold via {!Cmdliner.Arg.some}.}
{- If you want to describe a more complex, but short, behaviour use
the [~absent] parameter of {!Cmdliner.Arg.val-info}. Using this
parameter overrides the two previous ways. See
{{!args_detect_absent}this} example. }}
{2:args_completion How can I customize positional and option value completion?}
Positional argument values and option values are completed according
to the {{!Cmdliner.Arg.argconv}argument converter} you use for defining
the optional or positional argument.
A couple of predefined argument converter like {!Cmdliner.Arg.path},
{!Cmdliner.Arg.filepath} and {!Cmdliner.Arg.dirpath} or
{!Cmdliner.Arg.enum} automatically handle this for you.
If you would like to perform custom or more elaborate context
sensitive completions you can define your own argument converter with
a completion defined with {!Cmdliner.Arg.Completion.make}.
Here is an example where the first positional argument is completed
with the filenames found in a directory specified via the [--dir]
option (which defaults to the current working directory if unspecified).
{[
let dir = Arg.(value & opt dirpath "." & info ["d"; "dir"])
let dir_filenames_conv =
let complete dir ~token = match dir with
| None -> Error "Could not determine directory to lookup"
| Some dir ->
match Array.to_list (Sys.readdir dir) with
| exception Sys_error e -> Error (String.concat ": " [dir; e])
| fnames ->
let fnames = List.filter (String.starts_with ~prefix:token) fnames in
Ok (List.map Arg.Completion.string fnames)
in
let completion = Arg.Completion.make ~context:dir complete in
Arg.Conv.of_conv ~completion Arg.string
let pos0 = Arg.(required & pos 0 (some dir_filenames_conv) None & info [])
]}
Note that when you use [pos0] in a command line definition you also
need to make sure [dir] is part of the term otherwise the context will
always be [None]:
{[
let+ pos0 and+ dir and+ … in …
]}
{1:envs Environment variables}
{2:env_args How can environment variables define defaults?}
As mentioned in {!conv_env_defaults}, any non-required argument can be
defined by an environment variable when absent. This works by
specifying the [env] argument in the argument's {!Cmdliner.Arg.val-info}
information. For example:
{[
let msg =
let doc = "$(docv) is the message to utter." and docv = "MSG" in
let env = Cmd.Env.info "MESSAGE" in
Arg.(value & pos 0 string "Revolt!" & info [] ~env ~doc ~docv)
]}
When the first positional argument is absent it takes the default
value ["Revolt!"], unless the [MESSAGE] variable is defined in
the environment in which case it takes its value.
Cmdliner handles the environment variable lookup for you. By using the
[msg] term in your command definition all this gets automatically
documented in the tool help.
{2:env_cmd How do I document environment variables influencing a command?}
Environment variable that are used to change {{!env_args}argument
defaults} automatically get documented in a command's man page when
you use the argument's term in the command's term.
However if your command implementation looks up other variables and you
wish to document them in the command's man page, use the [envs]
argument of {!Cmdliner.Cmd.val-info} or the [docs_env] argument
of {!Cmdliner.Arg.val-info}.
This documents in the {!Cmdliner.Manpage.s_environment} manual section
of [tool] that [EDITOR] is looked up to find the tool to invoke to
edit the files:
{[
let editor_env = "EDITOR"
let tool … = … Sys.getenv_opt editor_env
let cmd =
let env = Cmd.Env.info editor_env ~doc:"The editor used to edit files." in
Cmd.make (Cmd.info "tool" ~envs:[env]) @@
…
]}
{1:cmds Commands}
{2:cmds_exit_code_docs How do I document command exit codes?}
Exit codes are documentd by {!Cmdliner.Cmd.Exit.type-info} values and
must be given to the command's {!Cmdliner.Cmd.type-info} value via the
[exits] optional arguments. For example:
{[
let conf_not_found = 1
let tool … =
let tool_cmd =
let exits =
Cmd.Exit.info conf_not_found "if no configuration could be found." ::
Cmd.Exit.defaults
in
Cmd.make (Cmd.info "mycmd" ~exits) @@
…
]}
{2:cmds_show_docs How do I show help in a command group's default?}
While it is usually {{!tip_avoid_default_command}not advised} to have a default
command in a group, just showing docs is acceptable. A term can request
Cmdliner's generated help by using {!Cmdliner.Term.val-ret}:
{[
let group_cmd =
let default = Term.(ret (const (`Help (`Auto, None)))) (* show help *) in
Cmd.group (Cmd.info "group") ~default @@
[first_cmd; second_cmd]
]}
{2:cmds_which_eval Which [Cmd] evaluation function should I use?}
There are (too) many {{!Cmdliner.Cmd.section-eval}command evaluation}
functions. They have grown organically in a rather ad-hoc manner. Some
of these are there for backwards compatibility reasons and advanced
usage for complex tools.
Here are the main ones to use and why you may want to use them which
essentially depends on how you want to handle errors and exit codes
in your tool function.
{ul
{- {!Cmdliner.Cmd.val-eval}. This forces your tool function to return [()].
The evaluation function always returns an exit code of [0] unless a
command line parsing error occurs.}
{- {!Cmdliner.Cmd.eval'}. {b Recommended}. This forces your tool function to
return an exit code [exit] which is returned by the evaluation function
unless a command line parsing error occurs. This is the recommended
function to use as it forces you to think about how to report errors and
design useful exit codes for users.}
{- {!Cmdliner.Cmd.eval_result} is akin to {!Cmdliner.Cmd.val-eval} except
it forces your function to return either [Ok ()] or [Error msg].
The evaluation function returns with exit code [0] unless [Error msg] is
computed in which case [msg] is printed on the error stream prefixed by the
executable name and the evaluation function returns with
exit code {!Cmdliner.Cmd.Exit.some_error}.}
{- {!Cmdliner.Cmd.eval_result'} is akin to {!Cmdliner.Cmd.eval_result}, except
the [Ok] case carries an exit code which is returned by the evaluation
function.}}
{2:cmds_howto_complete How can my tool support command line completion?}
The command line interface manual has all
{{!page-cli.cli_completion}the details} and
{{!page-cli.install_tool_completion} specific instructions} for
complementing your tool install. See also {!tip_tool_support}.
{2:cmds_listing How can I list all the commands of my tool?}
In a shell the invocation [cmdliner tool-commands $TOOL] lists every
command of the tool $TOOL.
{2:cmds_errmsg_styling How can I suppress error message styling?}
Since Cmdliner 2.0, error message printed on [stderr] use styled text
with ANSI escapes. Styled text is disabled if one of the conditions
mentioned {{!page-cli.error_message_styling}here} is met.
If you want to be more aggressive in suppressing them you can use the
[err] formatter argument of {{!Cmdliner.Cmd.section-eval}command
evaluation} functions with a suitable formatter on which a function
like
{{:https://erratique.ch/software/more/doc/More/Fmt/index.html#val-strip_styles}
this one} has been applied that automatically strips the styling.
{1:manpage Manpages}
{2:manpage_hide How do I prevent an item from being automatically listed?}
In general it's not a good idea to hide stuff from your users but in
case an item needs to be hidden you can use the special
{!Cmdliner.Manpage.s_none} section name. This ensures the item does
not get listed in any section.
{[
let secret = Arg.(value & flag & info ["super-secret"] ~docs:Manpage.s_none)
]}
{2:manpage_synopsis How can I write a better command synopsis section?}
Define the {!Cmdliner.Manpage.s_synopsis} section in the manpage of
your command. It takes over the one generated by Cmdliner. For example:
{[
let man = [
`S Manpage.s_synopsis;
`P "$(cmd) $(b,--) $(i,TOOL) [$(i,ARG)]…"; `Noblank;
`P "$(cmd) $(i,COMMAND) …";
`S Manpage.s_description;
`P "Without a command $(cmd) invokes $(i,TOOL)"; ]
]}
{2:manpage_install How can I install all the manpages of my tool?}
The command line interface manual
{{!page-cli.install_tool_manpages}the details} on how to install the manpages
of your tool and its subcommands. See also {!tip_tool_support}.
{1:blueprints Blueprints}
These blueprints when copied to a [src.ml] file can be compiled and run with:
{@sh[
ocamlfind ocamlopt -package cmdliner -linkgpkg src.ml
./a.out --help
]}
More concrete examples can be found on the {{!page-examples}examples page}
and the {{!page-tutorial}tutorial} may help too.
These examples follow a conventional {!tip_src_structure}.
{2:blueprint_min Minimal}
A minimal example.
{@ocaml name=blueprint_min.ml[
let tool () = Cmdliner.Cmd.Exit.ok
open Cmdliner
open Cmdliner.Term.Syntax
let cmd =
Cmd.make (Cmd.info "TODO" ~version:"v2.0.0+dune") @@
let+ unit = Term.const () in
tool unit
let main () = Cmd.eval' cmd
let () = if !Sys.interactive then () else exit (main ())
]}
{2:blueprint_tool A simple tool}
This is a tool that has a flag, an optional positional argument for
specifying an input file. It also responds to the [--version] option.
{@ocaml name=blueprint_tool.ml[
let exit_todo = 1
let tool ~flag ~infile = exit_todo
open Cmdliner
open Cmdliner.Term.Syntax
let flag = Arg.(value & flag & info ["flag"] ~doc:"The flag")
let infile =
let doc = "$(docv) is the input file. Use $(b,-) for $(b,stdin)." in
Arg.(value & pos 0 string "-" & info [] ~doc ~docv:"FILE")
let cmd =
let doc = "The tool synopsis is TODO" in
let man = [
`S Manpage.s_description;
`P "$(cmd) does TODO" ]
in
let exits =
Cmd.Exit.info exit_todo ~doc:"When there is stuff todo" ::
Cmd.Exit.defaults
in
Cmd.make (Cmd.info "TODO" ~version:"v2.0.0+dune" ~doc ~man ~exits) @@
let+ flag and+ infile in
tool ~flag ~infile
let main () = Cmd.eval' cmd
let () = if !Sys.interactive then () else exit (main ())
]}
{2:blueprint_cmds A tool with subcommands}
This is a tool with two subcommands [hey] and [ho]. If your tools
grows many subcommands you may want to follow these
{{!tip_src_structure}source code conventions}.
{@ocaml name=blueprint_cmds.ml[
let hey () = Cmdliner.Cmd.Exit.ok
let ho () = Cmdliner.Cmd.Exit.ok
open Cmdliner
open Cmdliner.Term.Syntax
let flag = Arg.(value & flag & info ["flag"] ~doc:"The flag")
let infile =
let doc = "$(docv) is the input file. Use $(b,-) for $(b,stdin)." in
Arg.(value & pos 0 file "-" & info [] ~doc ~docv:"FILE")
let hey_cmd =
let doc = "The hey command synopsis is TODO" in
Cmd.make (Cmd.info "hey" ~doc) @@
let+ unit = Term.const () in
ho ()
let ho_cmd =
let doc = "The ho command synopsis is TODO" in
Cmd.make (Cmd.info "ho" ~doc) @@
let+ unit = Term.const () in
ho unit
let cmd =
let doc = "The tool synopsis is TODO" in
Cmd.group (Cmd.info "TODO" ~version:"v2.0.0+dune" ~doc) @@
[hey_cmd; ho_cmd]
let main () = Cmd.eval' cmd
let () = if !Sys.interactive then () else exit (main ())
]}

453
unikernel/duniverse/cmdliner/doc/examples.mld Normal file
View file

@ -0,0 +1,453 @@
{0 Examples}
The examples are self-contained, cut and paste them in a file to play
with them. See also the suggested {{!page-cookbook.tip_src_structure}source
code structure} and program {{!page-cookbook.blueprints}blueprints}.
{1:example_rm A [rm] command}
We define the command line interface of an [rm] command with the
synopsis:
{v
rm [OPTION]… FILE…
v}
The [-f], [-i] and [-I] flags define the prompt behaviour of [rm]. It
is represented in our program by the [prompt] type. If more than one
of these flags is present on the command line the last one takes
precedence.
To implement this behaviour we map the presence of these flags to
values of the [prompt] type by using {!Cmdliner.Arg.vflag_all}.
This argument will contain all occurrences of the flag on the command
line and we just take the {!Cmdliner.Arg.last} one to define our term
value. If there is no occurrence the last value of the default list
[[Always]] is taken. This means the default prompt behaviour is [Always].
{@ocaml name=example_rm.ml[
(* Implementation of the command, we just print the args. *)
type prompt = Always | Once | Never
let prompt_str = function
| Always -> "always" | Once -> "once" | Never -> "never"
let rm ~prompt ~recurse files =
Printf.printf "prompt = %s\nrecurse = %B\nfiles = %s\n"
(prompt_str prompt) recurse (String.concat ", " files)
(* Command line interface *)
open Cmdliner
open Cmdliner.Term.Syntax
let files = Arg.(non_empty & pos_all file [] & info [] ~docv:"FILE")
let prompt =
let always =
let doc = "Prompt before every removal." in
Always, Arg.info ["i"] ~doc
in
let never =
let doc = "Ignore nonexistent files and never prompt." in
Never, Arg.info ["f"; "force"] ~doc
in
let once =
let doc = "Prompt once before removing more than three files, or when
removing recursively. Less intrusive than $(b,-i), while
still giving protection against most mistakes."
in
Once, Arg.info ["I"] ~doc
in
Arg.(last & vflag_all [Always] [always; never; once])
let recursive =
let doc = "Remove directories and their contents recursively." in
Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc)
let rm_cmd =
let doc = "Remove files or directories" in
let man = [
`S Manpage.s_description;
`P "$(cmd) removes each specified $(i,FILE). By default it does not
remove directories, to also remove them and their contents, use the
option $(b,--recursive) ($(b,-r) or $(b,-R)).";
`P "To remove a file whose name starts with a $(b,-), for example
$(b,-foo), use one of these commands:";
`Pre "$(cmd) $(b,-- -foo)"; `Noblank;
`Pre "$(cmd) $(b,./-foo)";
`P "$(cmd.name) removes symbolic links, not the files referenced by the
links.";
`S Manpage.s_bugs; `P "Report bugs to <bugs@example.org>.";
`S Manpage.s_see_also; `P "$(b,rmdir)(1), $(b,unlink)(2)" ]
in
Cmd.make (Cmd.info "rm" ~version:"v2.0.0+dune" ~doc ~man) @@
let+ prompt and+ recursive and+ files in
rm ~prompt ~recurse:recursive files
let main () = Cmd.eval rm_cmd
let () = if !Sys.interactive then () else exit (main ())
]}
{1:example_cp A [cp] command}
We define the command line interface of a [cp] command with the synopsis:
{v
cp [OPTION]… SOURCE… DEST
v}
The [DEST] argument must be a directory if there is more than one
[SOURCE]. This constraint is too complex to be expressed by the
combinators of {!Cmdliner.Arg}.
Hence we just give [DEST] the {!Cmdliner.Arg.string} type and verify
the constraint at the beginning of the implementation of [cp]. If the
constraint is unsatisfied we return an [`Error] result. By using
{!Cmdliner.Term.val-ret} on the command's term for [cp], [Cmdliner]
handles the error reporting.
{@ocaml name=example_cp.ml[
(* Implementation, we check the dest argument and print the args *)
let cp ~verbose ~recurse ~force srcs dest =
let many = List.length srcs > 1 in
if many && (not (Sys.file_exists dest) || not (Sys.is_directory dest))
then `Error (false, dest ^ ": not a directory") else
`Ok (Printf.printf
"verbose = %B\nrecurse = %B\nforce = %B\nsrcs = %s\ndest = %s\n"
verbose recurse force (String.concat ", " srcs) dest)
(* Command line interface *)
open Cmdliner
open Cmdliner.Term.Syntax
let verbose =
let doc = "Print file names as they are copied." in
Arg.(value & flag & info ["v"; "verbose"] ~doc)
let recurse =
let doc = "Copy directories recursively." in
Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc)
let force =
let doc = "If a destination file cannot be opened, remove it and try again."in
Arg.(value & flag & info ["f"; "force"] ~doc)
let srcs =
let doc = "Source file(s) to copy." in
Arg.(non_empty & pos_left ~rev:true 0 file [] & info [] ~docv:"SOURCE" ~doc)
let dest =
let doc = "Destination of the copy. Must be a directory if there is more \
than one $(i,SOURCE)." in
let docv = "DEST" in
Arg.(required & pos ~rev:true 0 (some string) None & info [] ~docv ~doc)
let cp_cmd =
let doc = "Copy files" in
let man_xrefs =
[`Tool "mv"; `Tool "scp"; `Page ("umask", 2); `Page ("symlink", 7)]
in
let man = [
`S Manpage.s_bugs;
`P "Email them to <bugs@example.org>."; ]
in
Cmd.make (Cmd.info "cp" ~version:"v2.0.0+dune" ~doc ~man ~man_xrefs) @@
Term.ret @@
let+ verbose and+ recurse and+ force and+ srcs and+ dest in
cp ~verbose ~recurse ~force srcs dest
let main () = Cmd.eval cp_cmd
let () = if !Sys.interactive then () else exit (main ())
]}
{1:example_tail A [tail] command}
We define the command line interface of a [tail] command with the
synopsis:
{v
tail [OPTION]… [FILE]…
v}
The [--lines] option whose value specifies the number of last lines to
print has a special syntax where a [+] prefix indicates to start
printing from that line number. In the program this is represented by
the [loc] type. We define a custom [loc_arg]
{{!Cmdliner.Arg.type-conv}argument converter} for this option.
The [--follow] option has an optional enumerated value. The argument
converter [follow], created with {!Cmdliner.Arg.enum} parses the
option value into the enumeration. By using {!Cmdliner.Arg.some} and
the [~vopt] argument of {!Cmdliner.Arg.opt}, the term corresponding to
the option [--follow] evaluates to [None] if [--follow] is absent from
the command line, to [Some Descriptor] if present but without a value
and to [Some v] if present with a value [v] specified.
{@ocaml name=example_tail.ml[
(* Implementation of the command, we just print the args. *)
type loc = bool * int
type verb = Verbose | Quiet
type follow = Name | Descriptor
let str = Printf.sprintf
let opt_str sv = function None -> "None" | Some v -> str "Some(%s)" (sv v)
let loc_str (rev, k) = if rev then str "%d" k else str "+%d" k
let follow_str = function Name -> "name" | Descriptor -> "descriptor"
let verb_str = function Verbose -> "verbose" | Quiet -> "quiet"
let tail ~lines ~follow ~verb ~pid files =
Printf.printf
"lines = %s\nfollow = %s\nverb = %s\npid = %s\nfiles = %s\n"
(loc_str lines) (opt_str follow_str follow) (verb_str verb)
(opt_str string_of_int pid) (String.concat ", " files)
(* Command line interface *)
open Cmdliner
open Cmdliner.Term.Syntax
let loc_arg =
let parser s =
try
if s <> "" && s.[0] <> '+'
then Ok (true, int_of_string s)
else Ok (false, int_of_string (String.sub s 1 (String.length s - 1)))
with Failure _ -> Error "unable to parse integer"
in
let pp ppf p = Format.fprintf ppf "%s" (loc_str p) in
Arg.Conv.make ~docv:"N" ~parser ~pp ()
let lines =
let doc = "Output the last $(docv) lines or use $(i,+)$(docv) to start \
output after the $(i,N)-1th line."
in
Arg.(value & opt loc_arg (true, 10) & info ["n"; "lines"] ~docv:"N" ~doc)
let follow =
let doc = "Output appended data as the file grows. $(docv) specifies how \
the file should be tracked, by its $(b,name) or by its \
$(b,descriptor)."
in
let follow = Arg.enum ["name", Name; "descriptor", Descriptor] in
Arg.(value & opt (some follow) ~vopt:(Some Descriptor) None &
info ["f"; "follow"] ~docv:"ID" ~doc)
let verb =
let quiet =
let doc = "Never output headers giving file names." in
Quiet, Arg.info ["q"; "quiet"; "silent"] ~doc
in
let verbose =
let doc = "Always output headers giving file names." in
Verbose, Arg.info ["v"; "verbose"] ~doc
in
Arg.(last & vflag_all [Quiet] [quiet; verbose])
let pid =
let doc = "With -f, terminate after process $(docv) dies." in
Arg.(value & opt (some int) None & info ["pid"] ~docv:"PID" ~doc)
let files = Arg.(value & (pos_all non_dir_file []) & info [] ~docv:"FILE")
let tail_cmd =
let doc = "Display the last part of a file" in
let man = [
`S Manpage.s_description;
`P "$(cmd) prints the last lines of each $(i,FILE) to standard output.
If no file is specified reads standard input. The number of printed
lines can be specified with the $(b,-n) option.";
`S Manpage.s_bugs;
`P "Report them to <bugs@example.org>.";
`S Manpage.s_see_also;
`P "$(b,cat)(1), $(b,head)(1)" ]
in
Cmd.make (Cmd.info "tail" ~version:"v2.0.0+dune" ~doc ~man) @@
let+ lines and+ follow and+ verb and+ pid and+ files in
tail ~lines ~follow ~verb ~pid files
let main () = Cmd.eval tail_cmd
let () = if !Sys.interactive then () else exit (main ())
]}
{1:example_darcs A [darcs] command}
We define the command line interface of a [darcs] command with the
synopsis:
{v
darcs [COMMAND] …
v}
The [--debug], [-q], [-v] and [--prehook] options are available in
each command. To avoid having to pass them individually to each
command we gather them in a record of type [copts]. By lifting the
record constructor [copts] into the term [copts_t] we now have a term
that we can pass to the commands to stand for an argument of type
[copts]. These options are documented in the section
{!Cmdliner.Manpage.s_common_options}.
The [help] command shows help about commands or other topics. The help
shown for commands is generated by [Cmdliner] by making an appropriate
use of {!Cmdliner.Term.val-ret} on the lifted [help] function.
If the program is invoked without a command we just want to show the
help of the program as printed by [Cmdliner] with [--help]. This is
done by the [default] term.
{@ocaml name=example_darcs.ml[
(* Implementations, just print the args. *)
type verb = Normal | Quiet | Verbose
type copts = { debug : bool; verb : verb; prehook : string option }
let str = Printf.sprintf
let opt_str sv = function None -> "None" | Some v -> str "Some(%s)" (sv v)
let opt_str_str = opt_str (fun s -> s)
let verb_str = function
| Normal -> "normal" | Quiet -> "quiet" | Verbose -> "verbose"
let pr_copts oc copts = Printf.fprintf oc
"debug = %B\nverbosity = %s\nprehook = %s\n"
copts.debug (verb_str copts.verb) (opt_str_str copts.prehook)
let initialize copts repodir = Printf.printf
"%arepodir = %s\n" pr_copts copts repodir
let record copts name email all ask_deps files = Printf.printf
"%aname = %s\nemail = %s\nall = %B\nask-deps = %B\nfiles = %s\n"
pr_copts copts (opt_str_str name) (opt_str_str email) all ask_deps
(String.concat ", " files)
let help copts man_format cmds topic = match topic with
| None -> `Help (`Pager, None) (* help about the program. *)
| Some topic ->
let topics = "topics" :: "patterns" :: "environment" :: cmds in
let conv = Cmdliner.Arg.enum (List.rev_map (fun s -> (s, s)) topics) in
let parse = Cmdliner.Arg.Conv.parser conv in
match parse topic with
| Error e -> `Error (false, e)
| Ok t when t = "topics" -> List.iter print_endline topics; `Ok ()
| Ok t when List.mem t cmds -> `Help (man_format, Some t)
| Ok t ->
let page = (topic, 7, "", "", ""), [`S topic; `P "Say something";] in
`Ok (Cmdliner.Manpage.print man_format Format.std_formatter page)
open Cmdliner
open Cmdliner.Term.Syntax
(* Help sections common to all commands *)
let help_secs = [
`S Manpage.s_common_options;
`P "These options are common to all commands.";
`S "MORE HELP";
`P "Use $(tool) $(i,COMMAND) --help for help on a single command.";`Noblank;
`P "Use $(tool) $(b,help patterns) for help on patch matching."; `Noblank;
`P "Use $(tool) $(b,help environment) for help on environment variables.";
`S Manpage.s_bugs; `P "Check bug reports at http://bugs.example.org.";]
(* Options common to all commands *)
let copts debug verb prehook = { debug; verb; prehook }
let copts_t =
let docs = Manpage.s_common_options in
let debug =
let doc = "Give only debug output." in
Arg.(value & flag & info ["debug"] ~docs ~doc)
in
let verb =
let doc = "Suppress informational output." in
let quiet = Quiet, Arg.info ["q"; "quiet"] ~docs ~doc in
let doc = "Give verbose output." in
let verbose = Verbose, Arg.info ["v"; "verbose"] ~docs ~doc in
Arg.(last & vflag_all [Normal] [quiet; verbose])
in
let prehook =
let doc = "Specify command to run before this $(tool) command." in
Arg.(value & opt (some string) None & info ["prehook"] ~docs ~doc)
in
Term.(const copts $ debug $ verb $ prehook)
(* Commands *)
let sdocs = Manpage.s_common_options
let initialize_cmd =
let repodir =
let doc = "Run the program in repository directory $(docv)." in
Arg.(value & opt file Filename.current_dir_name & info ["repodir"]
~docv:"DIR" ~doc)
in
let doc = "make the current directory a repository" in
let man = [
`S Manpage.s_description;
`P "Turns the current directory into a Darcs repository. Any
existing files and subdirectories become …";
`Blocks help_secs; ]
in
Cmd.make (Cmd.info "initialize" ~doc ~sdocs ~man) @@
let+ copts_t and+ repodir in
initialize copts_t repodir
let record_cmd =
let pname =
let doc = "Name of the patch." in
Arg.(value & opt (some string) None & info ["m"; "patch-name"] ~docv:"NAME"
~doc)
in
let author =
let doc = "Specifies the author's identity." in
Arg.(value & opt (some string) None & info ["A"; "author"] ~docv:"EMAIL"
~doc)
in
let all =
let doc = "Answer yes to all patches." in
Arg.(value & flag & info ["a"; "all"] ~doc)
in
let ask_deps =
let doc = "Ask for extra dependencies." in
Arg.(value & flag & info ["ask-deps"] ~doc)
in
let files = Arg.(value & (pos_all file) [] & info [] ~docv:"FILE or DIR") in
let doc = "create a patch from unrecorded changes" in
let man =
[`S Manpage.s_description;
`P "Creates a patch from changes in the working tree. If you specify
a set of files…";
`Blocks help_secs; ]
in
Cmd.make (Cmd.info "record" ~doc ~sdocs ~man) @@
let+ copts_t and+ pname and+ author and+ all and+ ask_deps and+ files in
record copts_t pname author all ask_deps files
let help_cmd =
let topic =
let doc = "The topic to get help on. $(b,topics) lists the topics." in
Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc)
in
let doc = "display help about darcs and darcs commands" in
let man =
[`S Manpage.s_description;
`P "Prints help about darcs commands and other subjects…";
`Blocks help_secs; ]
in
Cmd.make (Cmd.info "help" ~doc ~man) @@
Term.ret @@
let+ copts_t and+ man_format = Arg.man_format
and+ choice_names = Term.choice_names and+ topic in
help copts_t man_format choice_names topic
let main_cmd =
let doc = "a revision control system" in
let man = help_secs in
let info = Cmd.info "darcs" ~version:"v2.0.0+dune" ~doc ~sdocs ~man in
let default = Term.(ret (const (fun _ -> `Help (`Pager, None)) $ copts_t)) in
Cmd.group info ~default [initialize_cmd; record_cmd; help_cmd]
let main () = Cmd.eval main_cmd
let () = if !Sys.interactive then () else exit (main ())
]}

46
unikernel/duniverse/cmdliner/doc/index.mld Normal file
View file

@ -0,0 +1,46 @@
{0 Cmdliner {%html: <span class="version">v2.0.0+dune</span>%}}
Cmdliner provides a simple and compositional mechanism
to convert command line arguments to OCaml values and pass them to
your functions.
The library automatically handles command line completion, syntax
errors, help messages and UNIX man page generation. It supports
programs with single or multiple commands (like [git]) and respect
most of the
{{:http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap12.html}
POSIX} and
{{:http://www.gnu.org/software/libc/manual/html_node/Argument-Syntax.html}
GNU} conventions.
{1:manuals Manuals}
The following manuals are available.
{ul
{- The {{!page-tutorial}tutorial} makes you write your first command line
interface with Cmdliner.}
{- The {{!page-cookbook}cookbook} has a few off-the-shelf recipes,
tips about {{!page-cookbook.tip_src_structure}source code structure},
and {{!page-cookbook.blueprints}blueprints} to define your command lines
with Cmdliner.}
{- The {{!page-cli}command line interface manual} describes how command
lines and environment variables are parsed by Cmdliner and how command line
completion is performed. This can be communicated to the users of your
tools.}
{- The {{!page-tool_man}tool man page} manual describes how
Cmdliner generates man pages for your tools and their commands and how
you can format them.}
{- The {{!page-examples}examples page} has examples of a some
classic UNIX tools with their command line interface implemented by
Cmdliner.}}
{1:library Library [cmdliner]}
{!modules: Cmdliner}
{!modules:
Cmdliner.Arg
Cmdliner.Cmd
Cmdliner.Manpage
Cmdliner.Term
}

73
unikernel/duniverse/cmdliner/doc/tool_man.mld Normal file
View file

@ -0,0 +1,73 @@
{0:tool_man Tool man pages}
See also the {{!page-cli.help}section} about man pages in the command
line interface manual.
{1:manual Man page generation}
Man page sections for a command are printed in the order specified by
the [man] value given to {!Cmdliner.Cmd.val-info}. Unless
specified explicitly in the [man] value the following sections
are automatically created and populated for you:
{ul
{- {{!Cmdliner.Manpage.s_name}[NAME]} section.}
{- {{!Cmdliner.Manpage.s_synopsis}[SYNOPSIS]} section.}}
The various [doc] documentation strings specified by the command's
term arguments get inserted at the end of the documentation section
they respectively mention in their [docs] argument:
{ol
{- For commands, see {!Cmdliner.Cmd.val-info}.}
{- For positional arguments, see {!Cmdliner.Arg.type-info}. Those are listed iff
both the [docv] and [doc] string is specified by {!Cmdliner.Arg.val-info}.}
{- For optional arguments, see {!Cmdliner.Arg.val-info}.}
{- For exit statuses, see {!Cmdliner.Cmd.Exit.val-info}.}
{- For environment variables, see {!Cmdliner.Cmd.Env.val-info}.}}
If a [docs] section name is mentioned and does not exist in the command's
[man] value, an empty section is created for it, after which the [doc] strings
are inserted, possibly prefixed by boilerplate text (e.g. for
{!Cmdliner.Manpage.s_environment} and {!Cmdliner.Manpage.s_exit_status}).
If the created section is:
{ul
{- {{!Cmdliner.Manpage.standard_sections}standard}, it
is inserted at the right place in the order specified
{{!Cmdliner.Manpage.standard_sections}here}, but after a
possible non-standard
section explicitly specified by the command's [man] value since the latter
get the order number of the last previously specified standard section
or the order of {!Cmdliner.Manpage.s_synopsis} if there is no such section.}
{- non-standard, it is inserted before the {!Cmdliner.Manpage.s_commands}
section or the first subsequent existing standard section if it
doesn't exist. Taking advantage of this behaviour is discouraged,
you should declare manually your non standard section in the command's
manual page.}}
Finally note that the header of empty sections are dropped from the
output. This allows you to share section placements among many
commands and render them only if something actually gets inserted in
it.
{1:doclang Documentation markup language}
Manpage {{!Cmdliner.Manpage.block}blocks} and the doc strings of the
various [info] values support the following markup language.
{ul
{- Markup directives [$(i,text)] and [$(b,text)], where [text] is raw
text respectively rendered in italics and bold.}
{- Outside markup directives, context dependent variables of the form
[$(var)] are substituted by marked up data. For example in a command
man page [$(cmd)] is substituted by the command's invocation in
bold.}
{- Characters '$', '(', ')' and '\' can respectively be escaped by \$, \(, \)
and \\ . In OCaml strings this will be ["\\$"], ["\\("], ["\\)"],
["\\\\"]. Escaping '$' and '\' is mandatory everywhere. Escaping ')' is
mandatory only in markup directives. Escaping '(' is only here for
your symmetric pleasure. Any other sequence of characters starting
with a '\' is an illegal character sequence.}
{- Referring to unknown markup directives or variables will generate
errors on standard error during documentation generation.}}

228
unikernel/duniverse/cmdliner/doc/tutorial.mld Normal file
View file

@ -0,0 +1,228 @@
{0:tutorial Tutorial}
See also the {{!page-cookbook}cookbook},
{{!page-cookbook.blueprints}blueprints} and
{{!page-examples}examples}.
{1:terms Commands and terms}
With [Cmdliner] your tool's [main] function evaluates a command.
A command is a value of type {!Cmdliner.Cmd.t} which gathers a command
name and a term of type {!Cmdliner.Term.t}. A term represents both a
command line syntax fragment and an expression to be evaluated that
implements your tool. The type parameter of the term (and the command)
indicates the type of the result of the evaluation.
One way to create terms is by lifting regular OCaml values with
{!Cmdliner.Term.const}. Terms can be applied to terms evaluating to
functional values with {!Cmdliner.Term.app}.
For example, in a [revolt.ml] file, for the function:
{@ocaml name=example_revolt1.ml[
let revolt () = print_endline "Revolt!"
]}
the term :
{@ocaml name=example_revolt1.ml[
open Cmdliner
let revolt_term = Term.app (Term.const revolt) (Term.const ())
]}
is a term that evaluates to the result (and effect) of the [revolt]
function. This term can be associated to a command:
{@ocaml name=example_revolt1.ml[
let cmd_revolt = Cmd.make (Cmd.info "revolt") revolt_term
]}
and evaluated with {!Cmdliner.Cmd.val-eval}:
{@ocaml name=example_revolt1.ml[
let main () = Cmd.eval cmd_revolt
let () = if !Sys.interactive then () else exit (main ())
]}
This defines a command line tool named ["revolt"] (this name will be
used in error reporting and documentation generation), without command
line arguments, that just prints ["Revolt!"] on [stdout].
{@sh[
> ocamlfind ocamlopt -linkpkg -package cmdliner -o revolt revolt.ml
> ./revolt
Revolt!
]}
{1:term_syntax Term syntax}
There is a special syntax that uses OCaml's
{{:https://ocaml.org/manual/5.3/bindingops.html}binding operators} for
writing terms which is less error prone when the number of arguments
you want to give to your function grows. In particular it allows you to
easily lift functions which have labels.
So in fact the program we have just shown above is usually rather
written this way:
{@ocaml name=example_revolt2.ml[
let revolt () = print_endline "Revolt!"
open Cmdliner
open Cmdliner.Term.Syntax
let cmd_revolt =
Cmd.make (Cmd.info "revolt") @@
let+ () = Term.const () in
revolt ()
let main () = Cmd.eval cmd_revolt
let () = if !Sys.interactive then () else exit (main ())
]}
{1:args_as_terms Command line arguments as terms}
The combinators in the {!Cmdliner.Arg} module allow to extract command
line arguments as terms. These terms can then be applied to lifted
OCaml functions to be evaluated. A term that uses terms that correspond
to command line argument implicitely defines a command line syntax
fragment. We show this on an concrete example.
In a [chorus.ml] file, consider the [chorus] function that prints
repeatedly a given message :
{@ocaml name=example_chorus.ml[
let chorus ~count msg = for i = 1 to count do print_endline msg done
]}
we want to make it available from the command line with the synopsis:
{@sh[
chorus [-c COUNT | --count=COUNT] [MSG]
]}
where [COUNT] defaults to [10] and [MSG] defaults to ["Revolt!"]. We
first define a term corresponding to the [--count] option:
{@ocaml name=example_chorus.ml[
open Cmdliner
open Cmdliner.Term.Syntax
let count =
let doc = "Repeat the message $(docv) times." in
Arg.(value & opt int 10 & info ["c"; "count"] ~doc ~docv:"COUNT")
]}
This says that [count] is a term that evaluates to the value of an
optional argument of type [int] that defaults to [10] if unspecified
and whose option name is either [-c] or [--count]. The arguments [doc]
and [docv] are used to generate the option's man page information.
The term for the positional argument [MSG] is:
{@ocaml name=example_chorus.ml[
let msg =
let env =
let doc = "Overrides the default message to print." in
Cmd.Env.info "CHORUS_MSG" ~doc
in
let doc = "The message to print." in
Arg.(value & pos 0 string "Revolt!" & info [] ~env ~doc ~docv:"MSG")
]}
which says that [msg] is a term whose value is the positional argument
at index [0] of type [string] and defaults to ["Revolt!"] or the
value of the environment variable [CHORUS_MSG] if the argument is
unspecified on the command line. Here again [doc] and [docv] are used
for the man page information.
We can now define a term and command for invoking the [chorus] function
using the {{!term_syntax}term syntax} and the obscure but handy
{{:https://ocaml.org/manual/5.2/bindingops.html#ss%3Aletops-punning}
let-punning} OCaml notation. This also shows that the
value {!Cmdliner.Cmd.val-info} can be given more
information about the term we execute which is notably used to
to generate the tool's man page.
{@ocaml name=example_chorus.ml[
let chorus_cmd =
let doc = "Print a customizable message repeatedly" in
let man = [
`S Manpage.s_bugs;
`P "Email bug reports to <bugs@example.org>." ]
in
Cmd.make (Cmd.info "chorus" ~version:"v2.0.0+dune" ~doc ~man) @@
let+ count and+ msg in
chorus ~count msg
let main () = Cmd.eval chorus_cmd
let () = if !Sys.interactive then () else exit (main ())
]}
Since we provided a [~version] string, the tool will automatically
respond to the [--version] option by printing this string.
Besides a tool using {!Cmdliner.Cmd.val-eval} always responds to the
[--help] option by showing the tool's man page
{{!page-tool_man.manual}generated} using the information you provided
with {!Cmdliner.Cmd.val-info} and {!Cmdliner.Arg.val-info}. Here is
the manual generated by our example:
{v
> ocamlfind ocamlopt -linkpkg -package cmdliner -o chorus chorus.ml
> ./chorus --help
NAME
chorus - Print a customizable message repeatedly
SYNOPSIS
chorus [--count=COUNT] [OPTION]… [MSG]
ARGUMENTS
MSG (absent=Revolt! or CHORUS_MSG env)
The message to print.
OPTIONS
-c COUNT, --count=COUNT (absent=10)
Repeat the message COUNT times.
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
--version
Show version information.
EXIT STATUS
chorus exits with the following status:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
125 on unexpected internal errors (bugs).
ENVIRONMENT
These environment variables affect the execution of chorus:
CHORUS_MSG
Overrides the default message to print.
BUGS
Email bug reports to <bugs@example.org>.
v}
If a pager is available, this output is written to a pager. This help
is also available in plain text or in the
{{:http://www.gnu.org/software/groff/groff.html}groff} man page format
by invoking the program with the option [--help=plain] or
[--help=groff].
And with this you should master the basics of Cmdliner, for examples
of more complex command line definitions consult the
{{!page-examples}examples}. For more tips, off-the-shelf recipes and
conventions have look at the {{!page-cookbook}cookbook}.

1
unikernel/duniverse/cmdliner/dune Normal file
View file

@ -0,0 +1 @@
(env (_ (flags -g -bin-annot -safe-string))) ; Use the same flags as with ocamlbuild

3
unikernel/duniverse/cmdliner/dune-project Normal file
View file

@ -0,0 +1,3 @@
(lang dune 1.4)
(name cmdliner)
(version v2.0.0+dune)

8
unikernel/duniverse/cmdliner/pkg/META Normal file
View file

@ -0,0 +1,8 @@
description = "Declarative definition of command line interfaces for OCaml"
version = "2.0.0+dune"
requires = ""
archive(byte) = "cmdliner.cma"
archive(native) = "cmdliner.cmxa"
plugin(byte) = "cmdliner.cma"
plugin(native) = "cmdliner.cmxs"
exists_if = "cmdliner.cma cmdliner.cmxa"

17
unikernel/duniverse/cmdliner/pkg/pkg.ml Executable file
View file

@ -0,0 +1,17 @@
#!/usr/bin/env ocaml
#use "topfind"
#require "topkg"
open Topkg
(* This is only here for `topkg distrib`. Remove once
we switch to `b0 -- .release` *)
let distrib =
(* The default removes Makefile *)
let exclude_paths () = Ok [".git";".gitignore";".gitattributes";"_build"] in
Pkg.distrib ~exclude_paths ()
let () =
let opams = [Pkg.opam_file "cmdliner.opam"] in
Pkg.describe "cmdliner" ~distrib ~opams @@ fun c ->
Ok [ Pkg.mllib ~api:["Cmdliner"] "src/cmdliner.mllib" ]

14
unikernel/duniverse/cmdliner/src/cmdliner.ml Normal file
View file

@ -0,0 +1,14 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
module Manpage = Cmdliner_manpage
module Term = Cmdliner_term
module Cmd = struct
module Exit = Cmdliner_def.Exit
module Env = Cmdliner_def.Env
include Cmdliner_cmd
include Cmdliner_eval
end
module Arg = Cmdliner_arg

1183
unikernel/duniverse/cmdliner/src/cmdliner.mli Normal file
View file

File diff suppressed because it is too large Load diff

12
unikernel/duniverse/cmdliner/src/cmdliner.mllib Normal file
View file

@ -0,0 +1,12 @@
Cmdliner_trie
Cmdliner_base
Cmdliner_manpage
Cmdliner_def
Cmdliner_docgen
Cmdliner_msg
Cmdliner_cline
Cmdliner_arg
Cmdliner_term
Cmdliner_cmd
Cmdliner_eval
Cmdliner

625
unikernel/duniverse/cmdliner/src/cmdliner_arg.ml Normal file
View file

@ -0,0 +1,625 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
let rev_compare n0 n1 = compare n1 n0
(* Documentation formatting helpers *)
module Fmt = Cmdliner_base.Fmt
let doc_quote = Cmdliner_base.quote
let doc_alts = Cmdliner_base.alts_str
let doc_alts_enum ?quoted enum = doc_alts ?quoted (List.map fst enum)
let str_of_pp pp v = pp Format.str_formatter v; Format.flush_str_formatter ()
(* Invalid_argument strings *)
let err_not_opt = "Option argument without name"
let err_not_pos = "Positional argument with a name"
let err_incomplete_enum ss =
Printf.sprintf
"Arg.enum: missing printable string for a value, other strings are: %s"
(String.concat ", " ss)
(* Parse error strings *)
let err_no kind s = Fmt.str "no %a %s" Fmt.code_or_quote s kind
let err_not_dir s =
Fmt.str "%a %a" Fmt.code_or_quote s Fmt.ereason "is not a directory"
let err_is_dir s =
Fmt.str "%a %a" Fmt.code_or_quote s Fmt.ereason "is a directory"
let err_element kind s exp =
Fmt.str "%a element in %s (%a): %s"
Fmt.invalid () kind Fmt.code_or_quote s exp
let err_invalid kind s exp =
Fmt.str "@[%a %s %a, %s@]" Fmt.invalid () kind Fmt.code_or_quote s exp
let err_invalid_val = err_invalid "value"
let err_sep_miss sep s =
err_invalid_val s (Fmt.str "%a a '%c' separator" Fmt.missing () sep)
let err_invalid_enum var s enums =
let pp_docv ppf var =
if not (var = "ENUM" || var = "") then Fmt.pf ppf "%a " Fmt.code_var var
in
Fmt.str "@[%a@ %avalue %a, expected@ %a@]" Fmt.invalid () pp_docv var
Fmt.code_or_quote s Cmdliner_base.pp_alts enums
(* Argument converters *)
module Completion = Cmdliner_def.Arg_completion
module Conv = Cmdliner_def.Arg_conv
type 'a conv = 'a Conv.t
let some = Cmdliner_def.Arg_conv.some
let some' = Cmdliner_def.Arg_conv.some'
let none = Cmdliner_def.Arg_conv.none
(* Argument information *)
type 'a t = 'a Cmdliner_term.t
type info = Cmdliner_def.Arg_info.t
let info = Cmdliner_def.Arg_info.make
(* Arguments *)
let ( & ) f x = f x
let parse_error e = Error (`Parse e)
let env_bool_parse s = match String.lowercase_ascii s with
| "" | "false" | "no" | "n" | "0" -> Ok false
| "true" | "yes" | "y" | "1" -> Ok true
| s ->
let alts = doc_alts ~quoted:true ["true"; "yes"; "false"; "no" ] in
Error (err_invalid_val s alts)
let parse_to_list parser s = match parser s with
| Ok v -> Ok [v] | Error _ as e -> e
let try_env ei a parse ~absent = match Cmdliner_def.Arg_info.env a with
| None -> Ok absent
| Some env ->
let var = Cmdliner_def.Env.info_var env in
match Cmdliner_def.Eval.env_var ei var with
| None -> Ok absent
| Some v ->
match parse v with
| Error e -> parse_error (Cmdliner_msg.err_env_parse env ~err:e)
| Ok _ as v -> v
let arg_to_args a complete = Cmdliner_def.Arg_info.Set.singleton a complete
let list_to_args f l complete =
let add acc v = Cmdliner_def.Arg_info.Set.add (f v) complete acc in
List.fold_left add Cmdliner_def.Arg_info.Set.empty l
let flag a =
if Cmdliner_def.Arg_info.is_pos a then invalid_arg err_not_opt else
let convert ei cl = match Cmdliner_def.Cline.get_opt_arg cl a with
| [] -> try_env ei a env_bool_parse ~absent:false
| [_, _, None] -> Ok true
| [_, f, Some v] -> parse_error (Cmdliner_msg.err_flag_value f v)
| (_, f, _) :: (_ ,g, _) :: _ ->
parse_error (Cmdliner_msg.err_opt_repeated f g)
in
Cmdliner_term.make (arg_to_args a (Conv none)) convert
let flag_all a =
if Cmdliner_def.Arg_info.is_pos a then invalid_arg err_not_opt else
let a = Cmdliner_def.Arg_info.make_all_opts a in
let convert ei cl = match Cmdliner_def.Cline.get_opt_arg cl a with
| [] -> try_env ei a (parse_to_list env_bool_parse) ~absent:[]
| l ->
try
let truth (_, f, v) = match v with
| None -> true
| Some v -> failwith (Cmdliner_msg.err_flag_value f v)
in
Ok (List.rev_map truth l)
with Failure e -> parse_error e
in
Cmdliner_term.make (arg_to_args a (Conv none)) convert
let vflag v l =
let convert _ cl =
let rec aux fv = function
| (v, a) :: rest ->
begin match Cmdliner_def.Cline.get_opt_arg cl a with
| [] -> aux fv rest
| [_, f, None] ->
begin match fv with
| None -> aux (Some (f, v)) rest
| Some (g, _) -> failwith (Cmdliner_msg.err_opt_repeated g f)
end
| [_, f, Some v] -> failwith (Cmdliner_msg.err_flag_value f v)
| (_, f, _) :: (_, g, _) :: _ ->
failwith (Cmdliner_msg.err_opt_repeated g f)
end
| [] -> match fv with None -> v | Some (_, v) -> v
in
try Ok (aux None l) with Failure e -> parse_error e
in
let flag (_, a) =
if Cmdliner_def.Arg_info.is_pos a then invalid_arg err_not_opt else a
in
Cmdliner_term.make (list_to_args flag l (Conv none)) convert
let vflag_all v l =
let convert _ cl =
let rec aux acc = function
| (fv, a) :: rest ->
begin match Cmdliner_def.Cline.get_opt_arg cl a with
| [] -> aux acc rest
| l ->
let fval (k, f, v) = match v with
| None -> (k, fv)
| Some v -> failwith (Cmdliner_msg.err_flag_value f v)
in
aux (List.rev_append (List.rev_map fval l) acc) rest
end
| [] ->
if acc = [] then v else List.rev_map snd (List.sort rev_compare acc)
in
try Ok (aux [] l) with Failure e -> parse_error e
in
let flag (_, a) =
if Cmdliner_def.Arg_info.is_pos a then invalid_arg err_not_opt else
Cmdliner_def.Arg_info.make_all_opts a
in
Cmdliner_term.make (list_to_args flag l (Conv none)) convert
let parse_opt_value parse f v = match parse v with
| Ok v -> v | Error err -> failwith (Cmdliner_msg.err_opt_parse f ~err)
let opt ?vopt conv v a =
if Cmdliner_def.Arg_info.is_pos a then invalid_arg err_not_opt else
let absent = match Cmdliner_def.Arg_info.absent a with
| Cmdliner_def.Arg_info.Doc d as a when d <> "" -> a
| _ -> Cmdliner_def.Arg_info.Val (lazy (str_of_pp (Conv.pp conv) v))
in
let kind = match vopt with
| None -> Cmdliner_def.Arg_info.Opt
| Some dv -> Cmdliner_def.Arg_info.Opt_vopt (str_of_pp (Conv.pp conv) dv)
in
let docv = match Cmdliner_def.Arg_info.docv a with
| "" -> Conv.docv conv | docv -> docv
in
let a = Cmdliner_def.Arg_info.make_opt ~docv ~absent ~kind a in
let convert ei cl = match Cmdliner_def.Cline.get_opt_arg cl a with
| [] -> try_env ei a (Conv.parser conv) ~absent:v
| [_, f, Some v] ->
(try Ok (parse_opt_value (Conv.parser conv) f v) with
| Failure e -> parse_error e)
| [_, f, None] ->
begin match vopt with
| None -> parse_error (Cmdliner_msg.err_opt_value_missing f)
| Some optv -> Ok optv
end
| (_, f, _) :: (_, g, _) :: _ ->
parse_error (Cmdliner_msg.err_opt_repeated g f)
in
Cmdliner_term.make (arg_to_args a (Conv conv)) convert
let opt_all ?vopt conv v a =
if Cmdliner_def.Arg_info.is_pos a then invalid_arg err_not_opt else
let absent = match Cmdliner_def.Arg_info.absent a with
| Cmdliner_def.Arg_info.Doc d as a when d <> "" -> a
| _ -> Cmdliner_def.Arg_info.Val (lazy "")
in
let kind = match vopt with
| None -> Cmdliner_def.Arg_info.Opt
| Some dv -> Cmdliner_def.Arg_info.Opt_vopt (str_of_pp (Conv.pp conv) dv)
in
let docv = match Cmdliner_def.Arg_info.docv a with
| "" -> Conv.docv conv | docv -> docv
in
let a = Cmdliner_def.Arg_info.make_opt_all ~docv ~absent ~kind a in
let convert ei cl = match Cmdliner_def.Cline.get_opt_arg cl a with
| [] -> try_env ei a (parse_to_list (Conv.parser conv)) ~absent:v
| l ->
let parse (k, f, v) = match v with
| Some v -> (k, parse_opt_value (Conv.parser conv) f v)
| None -> match vopt with
| None -> failwith (Cmdliner_msg.err_opt_value_missing f)
| Some dv -> (k, dv)
in
try Ok (List.rev_map snd
(List.sort rev_compare (List.rev_map parse l))) with
| Failure e -> parse_error e
in
Cmdliner_term.make (arg_to_args a (Conv conv)) convert
(* Positional arguments *)
let parse_pos_value parse a v = match parse v with
| Ok v -> v
| Error err -> failwith (Cmdliner_msg.err_pos_parse a ~err)
let pos ?(rev = false) k conv v a =
if Cmdliner_def.Arg_info.is_opt a then invalid_arg err_not_pos else
let absent = match Cmdliner_def.Arg_info.absent a with
| Cmdliner_def.Arg_info.Doc d as a when d <> "" -> a
| _ -> Cmdliner_def.Arg_info.Val (lazy (str_of_pp (Conv.pp conv) v))
in
let pos = Cmdliner_def.Arg_info.pos ~rev ~start:k ~len:(Some 1) in
let docv = match Cmdliner_def.Arg_info.docv a with
| "" -> Conv.docv conv | docv -> docv
in
let a = Cmdliner_def.Arg_info.make_pos_abs ~docv ~absent ~pos a in
let convert ei cl = match Cmdliner_def.Cline.get_pos_arg cl a with
| [] -> try_env ei a (Conv.parser conv) ~absent:v
| [v] ->
(try Ok (parse_pos_value (Conv.parser conv) a v) with
| Failure e -> parse_error e)
| _ -> assert false
in
Cmdliner_term.make (arg_to_args a (Conv conv)) convert
let pos_list pos conv v a =
if Cmdliner_def.Arg_info.is_opt a then invalid_arg err_not_pos else
let docv = match Cmdliner_def.Arg_info.docv a with
| "" -> Conv.docv conv | docv -> docv
in
let a = Cmdliner_def.Arg_info.make_pos ~docv ~pos a in
let convert ei cl = match Cmdliner_def.Cline.get_pos_arg cl a with
| [] -> try_env ei a (parse_to_list (Conv.parser conv)) ~absent:v
| l ->
try Ok (List.rev (List.rev_map (parse_pos_value (Conv.parser conv) a) l))
with
| Failure e -> parse_error e
in
Cmdliner_term.make (arg_to_args a (Conv conv)) convert
let all = Cmdliner_def.Arg_info.pos ~rev:false ~start:0 ~len:None
let pos_all c v a = pos_list all c v a
let pos_left ?(rev = false) k =
let start = if rev then k + 1 else 0 in
let len = if rev then None else Some k in
pos_list (Cmdliner_def.Arg_info.pos ~rev ~start ~len)
let pos_right ?(rev = false) k =
let start = if rev then 0 else k + 1 in
let len = if rev then Some k else None in
pos_list (Cmdliner_def.Arg_info.pos ~rev ~start ~len)
(* Arguments as terms *)
let absent_error args =
let make_req a v acc =
let req_a = Cmdliner_def.Arg_info.make_req a in
Cmdliner_def.Arg_info.Set.add req_a v acc
in
Cmdliner_def.Arg_info.Set.fold make_req args Cmdliner_def.Arg_info.Set.empty
let value a = a
let err_arg_missing args =
parse_error @@
Cmdliner_msg.err_arg_missing (fst (Cmdliner_def.Arg_info.Set.choose args))
let required t =
let args = absent_error (Cmdliner_term.argset t) in
let convert ei cl = match (Cmdliner_term.parser t) ei cl with
| Ok (Some v) -> Ok v
| Ok None -> err_arg_missing args
| Error _ as e -> e
in
Cmdliner_term.make args convert
let non_empty t =
let args = absent_error (Cmdliner_term.argset t) in
let convert ei cl = match (Cmdliner_term.parser t) ei cl with
| Ok [] -> err_arg_missing args
| Ok l -> Ok l
| Error _ as e -> e
in
Cmdliner_term.make args convert
let last t =
let convert ei cl = match (Cmdliner_term.parser t) ei cl with
| Ok [] -> err_arg_missing (Cmdliner_term.argset t)
| Ok l -> Ok (List.hd (List.rev l))
| Error _ as e -> e
in
Cmdliner_term.make (Cmdliner_term.argset t) convert
(* Predefined converters. *)
let add_prefix_completion ~token name =
if Cmdliner_base.string_starts_with ~prefix:token name
then Some (Completion.string name) else None
let bool =
let alts = ["true"; "false"] in
let parser s = try Ok (bool_of_string s) with
| Invalid_argument _ -> Error (err_invalid_enum "" s alts)
in
let completion =
let func _ctx ~token =
Ok (List.filter_map (add_prefix_completion ~token) alts)
in
Completion.make func
in
Conv.make ~docv:"BOOL" ~parser ~pp:Format.pp_print_bool ~completion ()
let char =
let parser s = match String.length s = 1 with
| true -> Ok s.[0]
| false -> Error (err_invalid_val s "expected a character")
in
Conv.make ~docv:"CHAR" ~parser ~pp:Fmt.char ()
let parse_with t_of_str exp s =
try Ok (t_of_str s) with Failure _ -> Error (err_invalid_val s exp)
let int =
let parser = parse_with int_of_string "expected an integer" in
Conv.make ~docv:"INT" ~parser ~pp:Format.pp_print_int ()
let int32 =
let parser = parse_with Int32.of_string "expected a 32-bit integer" in
let pp ppf = Fmt.pf ppf "%ld" in
Conv.make ~docv:"INT32" ~parser ~pp ()
let int64 =
let parser = parse_with Int64.of_string "expected a 64-bit integer" in
let pp ppf = Fmt.pf ppf "%Ld" in
Conv.make ~docv:"INT64" ~parser ~pp ()
let nativeint =
let err = "expected a processor-native integer" in
let parser = parse_with Nativeint.of_string err in
let pp ppf = Fmt.pf ppf "%nd" in
Conv.make ~docv:"NATIVEINT" ~parser ~pp ()
let float =
let parser = parse_with float_of_string "expected a floating point number" in
Conv.make ~docv:"DOUBLE" ~parser ~pp:Format.pp_print_float ()
let string = Conv.make ~docv:"" ~parser:Result.ok ~pp:Fmt.string ()
let enum ?(docv = "ENUM") sl =
if sl = [] then invalid_arg Cmdliner_base.err_empty_list else
let t = Cmdliner_trie.of_list sl in
let parser s =
let legacy_prefixes = Cmdliner_trie.legacy_prefixes ~env:Sys.getenv_opt in
match Cmdliner_trie.find ~legacy_prefixes t s with
| Ok _ as v -> v
| Error `Ambiguous (* Only on legacy prefixes *) ->
let ambs = List.sort compare (Cmdliner_trie.ambiguities t s) in
Error (Cmdliner_base.err_ambiguous ~kind:"enum value" s ~ambs)
| Error `Not_found ->
let alts = List.rev (List.rev_map (fun (s, _) -> s) sl) in
Error (err_invalid_enum docv s alts)
in
let pp ppf v =
let sl_inv = List.rev_map (fun (s,v) -> (v,s)) sl in
try Fmt.string ppf (List.assoc v sl_inv)
with Not_found -> invalid_arg (err_incomplete_enum (List.map fst sl))
in
let completion =
let func _ctx ~token =
Ok (List.filter_map (fun (n, _) -> add_prefix_completion ~token n) sl)
in
Completion.make func
in
Conv.make ~docv ~parser ~pp ~completion ()
let path =
let parser s = Ok s in
let pp ppf s = Fmt.string ppf (Filename.quote s) in
let completion = Completion.complete_paths in
Conv.make ~docv:"PATH" ~parser ~pp ~completion ()
let filepath =
let parser s = Ok s in
let pp ppf s = Fmt.string ppf (Filename.quote s) in
let completion = Completion.complete_files in
Conv.make ~docv:"FILE" ~parser ~pp ~completion ()
let dirpath =
let parser s = Ok s in
let pp ppf s = Fmt.string ppf (Filename.quote s) in
let completion = Completion.complete_dirs in
Conv.make ~docv:"DIR" ~parser ~pp ~completion ()
let file =
let parser s =
if s = "-" then Ok s else
if Sys.file_exists s then Ok s else
Error (err_no "file or directory" s)
in
let completion = Completion.complete_files in
Conv.make ~docv:"PATH" ~parser ~pp:Fmt.string ~completion ()
let dir =
let parser s =
if Sys.file_exists s
then (if Sys.is_directory s then Ok s else Error (err_not_dir s))
else Error (err_no "directory" s)
in
let completion = Completion.complete_dirs in
Conv.make ~docv:"DIR" ~parser ~pp:Fmt.string ~completion ()
let non_dir_file =
let parser s =
if s = "-" then Ok s else
if Sys.file_exists s
then (if not (Sys.is_directory s) then Ok s else Error (err_is_dir s))
else Error (err_no "file" s)
in
let completion = Completion.complete_files in
Conv.make ~docv:"FILE" ~parser ~pp:Fmt.string ~completion ()
let split_and_parse sep parse s = (* raises [Failure] *)
let parse sub = match parse sub with
| Error e -> failwith e | Ok v -> v
in
let rec split accum j =
let i = try String.rindex_from s j sep with Not_found -> -1 in
if (i = -1) then
let p = String.sub s 0 (j + 1) in
if p <> "" then parse p :: accum else accum
else
let p = String.sub s (i + 1) (j - i) in
let accum' = if p <> "" then parse p :: accum else accum in
split accum' (i - 1)
in
split [] (String.length s - 1)
let list ?(sep = ',') conv =
let parser s = try Ok (split_and_parse sep (Conv.parser conv) s) with
| Failure e -> Error (err_element "list" s e)
in
let rec pp ppf = function
| [] -> ()
| v :: l ->
(Conv.pp conv) ppf v; if (l <> []) then (Fmt.char ppf sep; pp ppf l)
in
let docv = Printf.sprintf "%s[%c…]" (Conv.docv conv) sep in
Conv.make ~docv ~parser ~pp ()
let array ?(sep = ',') conv =
let parser s =
try Ok (Array.of_list (split_and_parse sep (Conv.parser conv) s)) with
| Failure e -> Error (err_element "array" s e)
in
let pp ppf v =
let max = Array.length v - 1 in
for i = 0 to max do
Conv.pp conv ppf v.(i); if i <> max then Fmt.char ppf sep
done
in
let docv = Printf.sprintf "%s[%c…]" (Conv.docv conv) sep in
Conv.make ~docv ~parser ~pp ()
let split_left sep s =
try
let i = String.index s sep in
let len = String.length s in
Some ((String.sub s 0 i), (String.sub s (i + 1) (len - i - 1)))
with Not_found -> None
let pair ?(sep = ',') conv0 conv1 =
let parser s = match split_left sep s with
| None -> Error (err_sep_miss sep s)
| Some (v0, v1) ->
match (Conv.parser conv0) v0, (Conv.parser conv1) v1 with
| Ok v0, Ok v1 -> Ok (v0, v1)
| Error e, _ | _, Error e -> Error (err_element "pair" s e)
in
let pp ppf (v0, v1) =
Fmt.pf ppf "%a%c%a" (Conv.pp conv0) v0 sep (Conv.pp conv1) v1
in
let docv = Printf.sprintf "%s%c%s" (Conv.docv conv0) sep (Conv.docv conv1) in
Conv.make ~docv ~parser ~pp ()
let t2 = pair
let t3 ?(sep = ',') conv0 conv1 conv2 =
let parser s = match split_left sep s with
| None -> Error (err_sep_miss sep s)
| Some (v0, s) ->
match split_left sep s with
| None -> Error (err_sep_miss sep s)
| Some (v1, v2) ->
match (Conv.parser conv0) v0, (Conv.parser conv1) v1,
(Conv.parser conv2) v2 with
| Ok v0, Ok v1, Ok v2 -> Ok (v0, v1, v2)
| Error e, _, _ | _, Error e, _ | _, _, Error e ->
Error (err_element "triple" s e)
in
let pp ppf (v0, v1, v2) =
let pp = Conv.pp in
Fmt.pf ppf "%a%c%a%c%a" (pp conv0) v0 sep (pp conv1) v1 sep (pp conv2) v2
in
let docv =
let docv = Conv.docv in
Printf.sprintf "%s%c%s%c%s" (docv conv0) sep (docv conv1) sep (docv conv2)
in
Conv.make ~docv ~parser ~pp ()
let t4 ?(sep = ',') conv0 conv1 conv2 conv3 =
let parser s = match split_left sep s with
| None -> Error (err_sep_miss sep s)
| Some(v0, s) ->
match split_left sep s with
| None -> Error (err_sep_miss sep s)
| Some (v1, s) ->
match split_left sep s with
| None -> Error (err_sep_miss sep s)
| Some (v2, v3) ->
match (Conv.parser conv0) v0, (Conv.parser conv1) v1,
(Conv.parser conv2) v2, (Conv.parser conv3) v3 with
| Ok v1, Ok v2, Ok v3, Ok v4 -> Ok (v1, v2, v3, v4)
| Error e, _, _, _ | _, Error e, _, _ | _, _, Error e, _
| _, _, _, Error e -> Error (err_element "quadruple" s e)
in
let pp ppf (v0, v1, v2, v3) =
let pp = Conv.pp in
Fmt.pf ppf "%a%c%a%c%a%c%a" (pp conv0) v0 sep (pp conv1) v1 sep (pp conv2)
v2 sep (pp conv3) v3
in
let docv =
let docv = Conv.docv in
Printf.sprintf "%s%c%s%c%s%c%s"
(docv conv0) sep (docv conv1) sep (docv conv2) sep (docv conv3)
in
Conv.make ~docv ~parser ~pp ()
(* Predefined arguments *)
let man_fmts =
["auto", `Auto; "pager", `Pager; "groff", `Groff; "plain", `Plain]
let man_fmt_docv = "FMT"
let man_fmts_enum = enum ~docv:man_fmt_docv man_fmts
let man_fmts_alts = doc_alts_enum man_fmts
let man_fmts_doc kind =
Printf.sprintf
"Show %s in format $(docv). The value $(docv) must be %s. \
With $(b,auto), the format is $(b,pager) or $(b,plain) whenever \
the $(b,TERM) env var is $(b,dumb) or undefined."
kind man_fmts_alts
let man_format =
let doc = man_fmts_doc "output" in
let docv = man_fmt_docv in
value & opt man_fmts_enum `Pager & info ["man-format"] ~docv ~doc
let stdopt_version ~docs =
value & flag & info ["version"] ~docs ~doc:"Show version information."
let stdopt_help ~docs =
let doc = man_fmts_doc "this help" in
let docv = man_fmt_docv in
value & opt ~vopt:(Some `Auto) (some man_fmts_enum) None &
info ["help"] ~docv ~docs ~doc
(* Deprecated *)
type 'a printer = 'a Conv.fmt
let docv_default = "VALUE"
let conv' ?docv (parser, pp) = Conv.make ~docv:docv_default ~parser ~pp ()
let conv ?docv (parser, pp) =
let parser s = match parser s with
| Ok _ as v -> v | Error (`Msg e) -> Error e
in
Conv.make ~docv:docv_default ~parser ~pp ()
let conv_printer = Conv.pp
let conv_docv = Conv.docv
let conv_parser conv =
fun s -> match Conv.parser conv s with
| Ok _ as v -> v | Error e -> Error (`Msg e)
let err_invalid s kind =
`Msg (Printf.sprintf "invalid value '%s', expected %s" s kind)
let parser_of_kind_of_string ~kind k_of_string =
fun s -> match k_of_string s with
| None -> Error (err_invalid s kind)
| Some v -> Ok v

142
unikernel/duniverse/cmdliner/src/cmdliner_arg.mli Normal file
View file

@ -0,0 +1,142 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(** Command line arguments as terms. *)
(* Converters *)
type 'a conv
module Completion : sig
type 'a directive
val value : ?doc:string -> 'a -> 'a directive
val string : ?doc:string -> string -> 'a directive
val files : 'a directive
val dirs : 'a directive
val restart : 'a directive
val message : string -> 'a directive
val raw : string -> 'a directive
type ('ctx, 'a) func =
'ctx option -> token:string -> ('a directive list, string) result
type 'a complete =
| Complete : 'ctx Cmdliner_term.t option * ('ctx, 'a) func -> 'a complete
type 'a t
val make : ?context:'ctx Cmdliner_term.t -> ('ctx, 'a) func -> 'a t
val complete : 'a t -> 'a complete
val complete_none : 'a t
val complete_files : 'a t
val complete_dirs : 'a t
val complete_paths : 'a t
val complete_restart : 'a t
end
module Conv : sig
type 'a parser = string -> ('a, string) result
type 'a fmt = Format.formatter -> 'a -> unit
type 'a t = 'a conv
val make :
?completion:'a Completion.t -> docv:string -> parser:'a parser ->
pp:'a fmt -> unit -> 'a t
val of_conv :
?completion:'a Completion.t -> ?docv:string -> ?parser:'a parser ->
?pp:'a fmt -> 'a t -> 'a t
val docv : 'a conv -> string
val parser : 'a conv -> 'a parser
val pp : 'a conv -> 'a fmt
val completion : 'a t -> 'a Completion.t
end
val some : ?none:string -> 'a conv -> 'a option conv
val some' : ?none:'a -> 'a conv -> 'a option conv
(* Arguments *)
type 'a t = 'a Cmdliner_term.t
type info
val info :
?deprecated:string -> ?absent:string -> ?docs:string ->
?doc_envs:Cmdliner_def.Env.info list -> ?docv:string -> ?doc:string ->
?env:Cmdliner_def.Env.info -> string list -> info
val ( & ) : ('a -> 'b) -> 'a -> 'b
val flag : info -> bool t
val flag_all : info -> bool list t
val vflag : 'a -> ('a * info) list -> 'a t
val vflag_all : 'a list -> ('a * info) list -> 'a list t
val opt : ?vopt:'a -> 'a conv -> 'a -> info -> 'a t
val opt_all : ?vopt:'a -> 'a conv -> 'a list -> info -> 'a list t
val pos : ?rev:bool -> int -> 'a conv -> 'a -> info -> 'a t
val pos_all : 'a conv -> 'a list -> info -> 'a list t
val pos_left : ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t
val pos_right : ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t
(* As terms *)
val value : 'a t -> 'a Cmdliner_term.t
val required : 'a option t -> 'a Cmdliner_term.t
val non_empty : 'a list t -> 'a list Cmdliner_term.t
val last : 'a list t -> 'a Cmdliner_term.t
(* Predefined arguments *)
val man_format : Cmdliner_manpage.format Cmdliner_term.t
val stdopt_version : docs:string -> bool Cmdliner_term.t
val stdopt_help : docs:string -> Cmdliner_manpage.format option Cmdliner_term.t
(* Predifined converters *)
val bool : bool conv
val char : char conv
val int : int conv
val nativeint : nativeint conv
val int32 : int32 conv
val int64 : int64 conv
val float : float conv
val string : string conv
val enum : ?docv:string -> (string * 'a) list -> 'a conv
val path : string conv
val filepath : string conv
val dirpath : string conv
val file : string conv
val dir : string conv
val non_dir_file : string conv
val list : ?sep:char -> 'a conv -> 'a list conv
val array : ?sep:char -> 'a conv -> 'a array conv
val pair : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv
val t2 : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv
val t3 : ?sep:char -> 'a conv ->'b conv -> 'c conv -> ('a * 'b * 'c) conv
val t4 :
?sep:char -> 'a conv ->'b conv -> 'c conv -> 'd conv ->
('a * 'b * 'c * 'd) conv
val doc_quote : string -> string
val doc_alts : ?quoted:bool -> string list -> string
val doc_alts_enum : ?quoted:bool -> (string * 'a) list -> string
(* Deprecated *)
type 'a printer = Format.formatter -> 'a -> unit
val conv' : ?docv:string -> 'a Conv.parser * 'a Conv.fmt -> 'a conv
val conv :
?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a Conv.fmt ->
'a conv
val conv_parser : 'a conv -> (string -> ('a, [`Msg of string]) result)
val conv_printer : 'a conv -> 'a printer
val conv_docv : 'a conv -> string
val parser_of_kind_of_string :
kind:string -> (string -> 'a option) ->
(string -> ('a, [`Msg of string]) result)

254
unikernel/duniverse/cmdliner/src/cmdliner_base.ml Normal file
View file

@ -0,0 +1,254 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
let strf = Printf.sprintf
(* Unique ids *)
let uid =
(* Thread-safe UIDs, Oo.id (object end) was used before.
Note this won't be thread-safe in multicore, we should use
Atomic but this is >= 4.12 and we have 4.08 for now. *)
let c = ref 0 in
fun () ->
let id = !c in
incr c; if id > !c then assert false (* too many ids *) else id
(* Edit distance
The stdlib has much better in but this will be only >= 5.4, maybe
in twenty years. *)
let edit_distance s0 s1 =
let minimum (a : int) (b : int) (c : int) : int = min a (min b c) in
let s0,s1 = if String.length s0 <= String.length s1 then s0,s1 else s1,s0 in
let m = String.length s0 and n = String.length s1 in
let rec rows row0 row i = match i > n with
| true -> row0.(m)
| false ->
row.(0) <- i;
for j = 1 to m do
if s0.[j - 1] = s1.[i - 1] then row.(j) <- row0.(j - 1) else
row.(j) <- minimum (row0.(j - 1) + 1) (row0.(j) + 1) (row.(j - 1) + 1)
done;
rows row row0 (i + 1)
in
rows (Array.init (m + 1) (fun x -> x)) (Array.make (m + 1) 0) 1
let suggest s candidates =
let add (min, acc) name =
let d = edit_distance s name in
if d = min then min, (name :: acc) else
if d < min then d, [name] else
min, acc
in
let dist, suggs = List.fold_left add (max_int, []) candidates in
if dist < 3 (* suggest only if not too far *) then suggs else []
(* Stdlib compatibility *)
let is_space = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false
let string_starts_with ~prefix s = (* available in 4.13 *)
let prefix_len = String.length prefix in
let s_len = String.length s in
if prefix_len > s_len then false else
let rec loop i =
if i = prefix_len then true
else if String.get prefix i = String.get s i then loop (i + 1)
else false
in
loop 0
let string_drop_first n s =
if n <= 0 then s else
if n >= String.length s then "" else
String.sub s n (String.length s - n)
(* Invalid argument strings *)
let err_empty_list = "empty list"
(* Formatting tools *)
module Fmt = struct
type 'a t = Format.formatter -> 'a -> unit
let str = Format.asprintf
let pf = Format.fprintf
let nop ppf _ = ()
let sp = Format.pp_print_space
let cut = Format.pp_print_cut
let string = Format.pp_print_string
let char = Format.pp_print_char
let comma ppf () = char ppf ','; sp ppf ()
let indent ppf c = for i = 1 to c do char ppf ' ' done
let list ?sep pp_v ppf l = Format.pp_print_list ?pp_sep:sep pp_v ppf l
let text = Format.pp_print_text
let lines ppf s =
let rec stop_at sat ~start ~max s =
if start > max then start else
if sat s.[start] then start else
stop_at sat ~start:(start + 1) ~max s
in
let sub s start stop ~max =
if start = stop then "" else
if start = 0 && stop > max then s else
String.sub s start (stop - start)
in
let is_nl c = c = '\n' in
let max = String.length s - 1 in
let rec loop start s = match stop_at is_nl ~start ~max s with
| stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~max)
| stop ->
Format.pp_print_string ppf (sub s start stop ~max);
Format.pp_force_newline ppf ();
loop (stop + 1) s
in
loop 0 s
let tokens ~spaces ppf s = (* collapse white and hint spaces (maybe) *)
let i_max = String.length s - 1 in
let flush start stop = string ppf (String.sub s start (stop - start + 1)) in
let rec skip_white i =
if i > i_max then i else
if is_space s.[i] then skip_white (i + 1) else i
in
let rec loop start i =
if i > i_max then flush start i_max else
if not (is_space s.[i]) then loop start (i + 1) else
let next_start = skip_white i in
(flush start (i - 1); if spaces then sp ppf () else char ppf ' ';
if next_start > i_max then () else loop next_start next_start)
in
loop 0 0
(* Text styling *)
type styler = Ansi | Plain
let styler' =
ref begin match Sys.getenv_opt "NO_COLOR" with
| Some s when s <> "" -> Plain
| _ ->
match Sys.getenv_opt "TERM" with
| Some "dumb" -> Plain
| None when Sys.backend_type <> Other "js_of_ocaml" -> Plain
| _ -> Ansi
end
let set_styler styler = styler' := styler
let styler () = !styler'
let sgr_of_style = function
| `Bold -> "01"
| `Underline -> "04"
| `Fg `Red -> string_of_int (30 + 1)
| `Fg `Yellow -> string_of_int (30 + 3)
let sgrs_of_styles styles = String.concat ";" (List.map sgr_of_style styles)
let ansi_esc = "\x1B["
let sgr_reset = "\x1B[m"
let ansi styles ppf s =
let sgrs = String.concat "" [ansi_esc; sgrs_of_styles styles; "m"] in
Format.pp_print_as ppf 0 sgrs;
string ppf s;
Format.pp_print_as ppf 0 sgr_reset
let st styles ppf s = match !styler' with
| Plain -> string ppf s
| Ansi -> ansi styles ppf s
let code ppf v = st [`Bold] ppf v
let code_var ppf v = st [`Underline] ppf v
let code_or_quote ppf v = match !styler' with
| Plain -> char ppf '\''; string ppf v; char ppf '\''
| Ansi -> ansi [`Bold] ppf v
let ereason ppf s = match !styler' with
| Plain -> string ppf s
| Ansi -> ansi [`Fg `Red] ppf s
let wreason ppf s = match !styler' with
| Plain -> string ppf s
| Ansi -> ansi [`Fg `Yellow] ppf s
let missing ppf () = ereason ppf "missing"
let invalid ppf () = ereason ppf "invalid"
let unknown ppf () = ereason ppf "unknown"
let deprecated ppf () = wreason ppf "deprecated"
let puterr ppf () = st [`Bold; `Fg `Red] ppf "Error"; char ppf ':'
let styled_text ppf s =
(* Detects ANSI escapes and prints them as 0 width. Collapses spaces
and newlines to single space except for blank lines which are
preserved. *)
let rec loop ppf s i max =
if i > max then () else
let ansi = s.[i] = '\x1B' && i + 1 < max && s.[i+1] = '[' in
if not ansi then match s.[i] with
| ' ' when i = max || s.[i+1] = ' ' || s.[i+1] = '\n' ->
loop ppf s (i + 1) max
| ' ' -> sp ppf (); loop ppf s (i + 1) max
| '\n' when i = max || s.[i+1] = ' ' -> loop ppf s (i + 1) max
| '\n' when s.[i+1] = '\n' ->
Format.pp_force_newline ppf ();
if i > 0 && s.[i-1] <> '\n' then Format.pp_force_newline ppf ();
loop ppf s (i + 1) max
| '\n' -> sp ppf (); loop ppf s (i + 1) max
| c -> char ppf s.[i]; loop ppf s (i + 1) max
else begin
let k = ref (i + 2) in
while (!k <= max && s.[!k] <> 'm') do incr k done;
let esc = String.sub s i (!k - i + 1) in
Format.pp_print_as ppf 0 esc;
loop ppf s (!k + 1) max
end
in
loop ppf s 0 (String.length s - 1)
end
(* Converter (end-user) error messages *)
let err_multi_def ~kind name doc v v' = (* programming error *)
strf "%s %s defined twice (doc strings are '%s' and '%s')"
kind name (doc v) (doc v')
let quote s = strf "'%s'" s (* Exposed in the API do not change *)
let _alts_str ~styled ?quoted ppf alts =
let quote = match quoted with
| None -> fun ppf s -> Fmt.pf ppf "$(b,%s)" s
| Some quoted ->
if not quoted then Fmt.string else
if styled then Fmt.code_or_quote else
fun ppf s -> Fmt.pf ppf "'%s'" s
in
match alts with
| [] -> invalid_arg err_empty_list
| [a] -> quote ppf a
| [a; b] -> Fmt.pf ppf "either@ %a@ or@ %a" quote a quote b
| alts ->
let rev_alts = List.rev alts in
Fmt.pf ppf "one@ of@ %a@ or@ %a"
Fmt.(list ~sep:comma quote) (List.rev (List.tl rev_alts))
quote (List.hd rev_alts)
let alts_str ?quoted alts = (* Exposed in the API do not change *)
Fmt.str "@[%a@]" (_alts_str ~styled:false ?quoted) alts
let pp_alts ppf alts =
_alts_str ~styled:true ~quoted:true ppf alts
let err_ambiguous ~kind s ~ambs =
Fmt.str "@[%s %a %a@ and@ could@ be@ %a@]"
kind Fmt.code_or_quote s Fmt.ereason "ambiguous" pp_alts ambs
let err_unknown ?(dom = []) ?(hints = []) ~kind v =
let hints ppf () = match hints, dom with
| [], [] -> ()
| [], dom -> Fmt.pf ppf ". Must@ be@ %a" pp_alts dom
| hints, _ -> Fmt.pf ppf ". Did@ you@ mean@ %a?" pp_alts hints
in
Fmt.str "@[%a %s@ %a%a@]" Fmt.unknown () kind Fmt.code_or_quote v hints ()

60
unikernel/duniverse/cmdliner/src/cmdliner_base.mli Normal file
View file

@ -0,0 +1,60 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(** A few helpful base definitions. *)
val uid : unit -> int
(** [uid ()] is new unique for the program run. *)
val suggest : string -> string list -> string list
(** [suggest near candidates] suggest values from [candidates]
not too far from [near]. *)
val is_space : char -> bool
val string_starts_with : prefix:string -> string -> bool
val string_drop_first : int -> string -> string
(* Formatters *)
module Fmt : sig
type 'a t = Format.formatter -> 'a -> unit
val str : ('a, Format.formatter, unit, string) format4 -> 'a
val pf : Format.formatter -> ('a, Format.formatter, unit) format -> 'a
val nop : 'a t
val sp : unit t
val comma : unit t
val cut : unit t
val char : char t
val string : string t
val indent : int t
val list : ?sep:unit t -> 'a t -> 'a list t
val styled_text : string t
val lines : string t
val tokens : spaces:bool -> string t
val text : string t
val code : string t
val code_var : string t
val code_or_quote : string t
val ereason : string t
val missing : unit t
val invalid : unit t
val deprecated : unit t
val puterr : unit t
type styler = Ansi | Plain
val styler : unit -> styler
end
(* Error message helpers *)
val quote : string -> string
val pp_alts : string list Fmt.t
val alts_str : ?quoted:bool -> string list -> string
val err_empty_list : string
val err_ambiguous : kind:string -> string -> ambs:string list -> string
val err_unknown :
?dom:string list -> ?hints:string list -> kind:string -> string -> string
val err_multi_def :
kind:string -> string -> ('b -> string) -> 'b -> 'b -> string

345
unikernel/duniverse/cmdliner/src/cmdliner_cline.ml Normal file
View file

@ -0,0 +1,345 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(* A command line stores pre-parsed information about the command
line's arguments in a more structured way. Given the
Cmdliner_def.Arg_info.t values mentioned in a term and Sys.argv
(without exec name) we parse the command line into
[Cmdliner_def.Cline.t] which is map of [Cmdliner_def.Arg_info.t]
values to [Cmdliner_def.Cline.arg] values. This map is used by the
term's closures to retrieve and convert command line arguments (see
the [Cmdliner_arg] module). *)
(* Completion *)
let complete_prefix = "--__complete="
let has_complete_prefix s =
Cmdliner_base.string_starts_with ~prefix:complete_prefix s
let get_token_to_complete s =
Cmdliner_base.string_drop_first (String.length complete_prefix) s
let is_opt_to_complete s = (* assert (has_complete_prefix s) *)
String.length s > String.length complete_prefix &&
s.[String.length complete_prefix] = '-'
let maybe_token_to_complete ~for_completion s =
if not for_completion || not (has_complete_prefix s) then None else
Some (get_token_to_complete s)
(* Command lines *)
let err_multi_opt_name_def name arg_info arg_info' =
Cmdliner_base.err_multi_def ~kind:"option name" name
Cmdliner_def.Arg_info.doc arg_info arg_info'
let arg_info_indexes arg_infos =
(* from [args] returns a trie mapping the names of optional arguments to
their arg_info, a list with all arg_info for positional arguments and
a Cmdliner_def.Cline.t mapping each arg_info to an empty [arg]. *)
let rec loop optidx posidx cline = function
| [] -> optidx, posidx, cline
| arg_info :: l ->
match Cmdliner_def.Arg_info.is_pos arg_info with
| true ->
let cline = Cmdliner_def.Cline.add arg_info (P []) cline in
loop optidx (arg_info :: posidx) cline l
| false ->
let add t name = match Cmdliner_trie.add t name arg_info with
| `New t -> t
| `Replaced (a', _) ->
invalid_arg (err_multi_opt_name_def name arg_info a')
in
let names = Cmdliner_def.Arg_info.opt_names arg_info in
let optidx = List.fold_left add optidx names in
let cline = Cmdliner_def.Cline.add arg_info (O []) cline in
loop optidx posidx cline l
in
let cline = Cmdliner_def.Cline.empty in
let arg_infos = Cmdliner_def.Arg_info.Set.elements arg_infos in
loop Cmdliner_trie.empty [] cline arg_infos
(* Optional argument parsing *)
(* Note on option completion. Technically when trying to complete an
option we could try to avoid mentioning names that have already be
mentioned and that are not repeatable. Sometimes not being able to
complete what we know exists ends up being more confusing than
enlightening so we don't do that for now.
Also the code is quite messy, perhaps we should cleanly separate
parsing for completion and parsing for evaluation. *)
let is_opt s = String.length s > 1 && s.[0] = '-'
let is_short_opt s = String.length s = 2 && s.[0] = '-'
let parse_opt_arg s =
(* (name, value) of opt arg, assert len > 1. except if complete *)
let is_completion = has_complete_prefix s in
let s = if is_completion then get_token_to_complete s else s in
let l = String.length s in
if l <= 1 then "-", None, is_completion else
if s.[1] <> '-' then (* short opt *)
if l = 2 then s, None, is_completion else
String.sub s 0 2, Some (String.sub s 2 (l - 2)) (* with glued opt arg *),
is_completion
else try (* long opt *)
let i = String.index s '=' in
String.sub s 0 i, Some (String.sub s (i + 1) (l - i - 1)), is_completion
with Not_found -> s, None, is_completion
let hint_matching_opt optidx s =
(* hint option names that could match [s] in [optidx]. *)
if String.length s <= 2 then [] else
let short_opt, long_opt =
if s.[1] <> '-'
then s, Printf.sprintf "-%s" s
else String.sub s 1 (String.length s - 1), s
in
let short_opt, _, _ = parse_opt_arg short_opt in
let long_opt, _, _ = parse_opt_arg long_opt in
let all = Cmdliner_trie.ambiguities optidx "-" in
match List.mem short_opt all, Cmdliner_base.suggest long_opt all with
| false, [] -> []
| false, l -> l
| true, [] -> [short_opt]
| true, l -> if List.mem short_opt l then l else short_opt :: l
let parse_opt_value ~for_completion cline arg_info name value args =
(* Either we got a value glued in [value] or we need to get one in [args]
in this case we need to take care of a possible completion token *)
match Cmdliner_def.Arg_info.opt_kind arg_info with
| Flag -> (* Flags have no values but we may get dash sharing in [value] *)
begin match value with
| None -> None, None, args
| Some v when is_short_opt name -> (* short flag dash sharing *)
None, None, ("-" ^ v) :: args
| Some _ -> (* an error but this is reported during typed parsing *)
None, value, args
end
| _ ->
match value with
| Some _ -> None, value, args
| None -> (* Get it from the next argument. *)
match args with
| [] -> None, None, args
| v :: rest when for_completion && has_complete_prefix v ->
let v = get_token_to_complete v in
if is_opt v then (* not an option value *) None, None, args else
let comp =
Cmdliner_def.Complete.make ~token:v (Opt_value arg_info)
in
Some comp, None, rest
| v :: rest ->
if is_opt v then None, None, args else None, Some v, rest
let try_complete_opt_value cline arg_info name value args =
(* At that point we found a matching option name so this should be mostly
about completing a glued option value, but there are twists. *)
match Cmdliner_def.Arg_info.opt_kind arg_info with
| Cmdliner_def.Arg_info.Flag ->
begin match value with
| Some v when is_short_opt name ->
(* short flag dash sharing, push the completion *)
let args = (complete_prefix ^ "-" ^ v) :: args in
None, None, args
| Some v ->
(* This is actually a parse error, flags have no value. We
make it an option completion but the completions will
eventually be empty (the prefix won't match) *)
Some (Cmdliner_def.Complete.make ~token:(name ^ v) Opt_name),
None, args
| None ->
(* We have in fact a fully completed flag turn it into an
option completion. *)
Some (Cmdliner_def.Complete.make ~token:name Opt_name), None, args
end
| _ ->
begin match value with
| Some token ->
Some (Cmdliner_def.Complete.make ~token (Opt_value arg_info)), None,
args
| None ->
(* We have a fully completed option name, we don't try to
lookup what happens in the next argument which should
hold the value if any, we just turn it into an option
completion. *)
Some (Cmdliner_def.Complete.make ~token:name Opt_name), None, args
end
let parse_opt_args
~peek_opts ~legacy_prefixes ~for_completion optidx cline args
=
(* returns an updated [cline] cmdline according to the options found in [args]
with the trie index [optidx]. Positional arguments are returned in order
in a list. *)
let rec loop errs k comp cline pargs = function
| [] -> List.rev errs, comp, cline, false, List.rev pargs
| "--" :: args ->
List.rev errs, comp, cline, true, (List.rev_append pargs args)
| s :: args ->
let do_parse =
is_opt s &&
(if not for_completion then true else
if not (has_complete_prefix s) then true else
is_opt_to_complete s)
in
if not do_parse then loop errs (k + 1) comp cline (s :: pargs) args else
let name, value, is_completion = parse_opt_arg s in
match Cmdliner_trie.find ~legacy_prefixes optidx name with
| Ok arg_info ->
let acomp, value, args =
if is_completion
then try_complete_opt_value cline arg_info name value args
else parse_opt_value ~for_completion cline arg_info name value args
in
let comp = match acomp with Some _ -> acomp | None -> comp in
let arg : Cmdliner_def.Cline.arg =
O ((k, name, value) ::
Cmdliner_def.Cline.get_opt_arg cline arg_info)
in
let cline = Cmdliner_def.Cline.add arg_info arg cline in
loop errs (k + 1) comp cline pargs args
| Error `Not_found when for_completion ->
if not is_completion then
(* Drop the data, if the user thought this was an opt with
an argument this may confuse positional args but there's
not much we can do. *)
loop errs (k + 1) comp cline pargs args
else
let token = name ^ Option.value ~default:"" value in
let comp = Some (Cmdliner_def.Complete.make ~token Opt_name) in
loop errs (k + 1) comp cline pargs args
| Error `Not_found when peek_opts ->
loop errs (k + 1) comp cline pargs args
| Error `Not_found ->
let hints = hint_matching_opt optidx s in
let err = Cmdliner_base.err_unknown ~kind:"option" ~hints name in
loop (err :: errs) (k + 1) comp cline pargs args
| Error `Ambiguous (* Only on legacy prefixes *) ->
let ambs = Cmdliner_trie.ambiguities optidx name in
let ambs = List.sort compare ambs in
let err = Cmdliner_base.err_ambiguous ~kind:"option" name ~ambs in
loop (err :: errs) (k + 1) comp cline pargs args
in
let errs, comp, cline, has_dashdash, pargs = loop [] 0 None cline [] args in
if errs = [] then Ok (comp, cline, has_dashdash, pargs) else
match comp with
| Some _ -> Ok (comp, cline, has_dashdash, pargs)
| None ->
let err = String.concat "\n" errs in
Error (err, cline, has_dashdash, pargs)
(* Positional argument parsing *)
let take_range ~for_completion start stop l =
let rec loop i comp acc = function
| [] -> comp, (List.rev acc)
| v :: vs ->
if i < start then loop (i + 1) comp acc vs else
if i <= stop then match maybe_token_to_complete ~for_completion v with
| Some _ as comp -> loop (i + 1) comp (v :: acc) vs
| None -> loop (i + 1) comp (v :: acc) vs
else comp, List.rev acc
in
loop 0 None [] l
let parse_pos_args ~for_completion posidx comp cline ~has_dashdash pargs =
(* returns an updated [cline] cmdline in which each positional arg mentioned
in the list index [posidx], is given a value according the list
of positional arguments values [pargs]. *)
if pargs = [] then
let misses = List.filter Cmdliner_def.Arg_info.is_req posidx in
if misses = [] then Ok (comp, cline) else
match comp with
| Some _ -> Ok (comp, cline)
| None -> Error (Cmdliner_msg.err_pos_misses misses, cline)
else
let last = List.length pargs - 1 in
let pos rev k = if rev then last - k else k in
let rec loop misses comp cline max_spec = function
| [] -> misses, comp, cline, max_spec
| arg_info :: al ->
let apos = Cmdliner_def.Arg_info.pos_kind arg_info in
let rev = Cmdliner_def.Arg_info.pos_rev apos in
let start = pos rev (Cmdliner_def.Arg_info.pos_start apos) in
let stop = match Cmdliner_def.Arg_info.pos_len apos with
| None -> pos rev last
| Some n -> pos rev (Cmdliner_def.Arg_info.pos_start apos + n - 1)
in
let start, stop = if rev then stop, start else start, stop in
let comp, args = match take_range ~for_completion start stop pargs with
| None, args -> comp, args
| Some token, args ->
let comp =
Cmdliner_def.Complete.make ~after_dashdash:has_dashdash ~token
(Opt_name_or_pos_value arg_info)
in
Some comp, args
in
let max_spec = max stop max_spec in
let cline = Cmdliner_def.Cline.add arg_info (P args) cline in
let misses = match Cmdliner_def.Arg_info.is_req arg_info && args = [] with
| true -> arg_info :: misses
| false -> misses
in
loop misses comp cline max_spec al
in
let misses, comp, cline, max_spec = loop [] comp cline (-1) posidx in
if misses <> [] then begin
if Option.is_some comp then Ok (comp, cline) else
Error (Cmdliner_msg.err_pos_misses misses, cline)
end else
if last <= max_spec then Ok (comp, cline) else
if Option.is_some comp then Ok (comp, cline) else
let comp, excess = take_range ~for_completion (max_spec + 1) last pargs in
match comp with
| None -> Error (Cmdliner_msg.err_pos_excess excess, cline)
| Some token ->
let comp =
Cmdliner_def.Complete.make ~after_dashdash:has_dashdash ~token Opt_name
in
Ok (Some comp, cline)
let create ?(peek_opts = false) ~legacy_prefixes ~for_completion al args =
let optidx, posidx, cline = arg_info_indexes al in
match
parse_opt_args ~for_completion ~peek_opts ~legacy_prefixes optidx cline args
with
| Ok (comp, cline, _has_dashdash, _pargs) when peek_opts ->
begin match comp with
| None -> `Ok cline
| Some comp -> `Complete (comp, cline)
end
| Ok (comp, cline, has_dashdash, pargs) ->
begin match
parse_pos_args ~for_completion posidx comp cline ~has_dashdash pargs
with
| Ok (None, _) | Error _ when for_completion ->
(* Normally we should have found a completion token This
may fail to happen if pos args are ill defined: we may miss the
completion token. Just make sure we do a completion. *)
begin match List.find_opt has_complete_prefix pargs with
| None -> assert false
| Some arg ->
match maybe_token_to_complete ~for_completion:true arg with
| None -> assert false
| Some token ->
let comp =
Cmdliner_def.Complete.make
~after_dashdash:has_dashdash ~token Opt_name
in
`Complete (comp, cline)
end
| Ok (None, cline) -> `Ok cline
| Ok (Some comp, cline) -> `Complete (comp, cline)
| Error v -> `Error v
end
| Error (errs, cline, has_dashdash, pargs) ->
match
parse_pos_args ~for_completion posidx None cline ~has_dashdash pargs
with
| Ok (Some comp, cline) -> `Complete (comp, cline)
| _ -> `Error (errs, cline)

19
unikernel/duniverse/cmdliner/src/cmdliner_cline.mli Normal file
View file

@ -0,0 +1,19 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(** Command lines. *)
val is_opt : string -> bool
val has_complete_prefix : string -> bool
val get_token_to_complete : string -> string
(** {1:cli Command lines} *)
val create :
?peek_opts:bool -> legacy_prefixes:bool -> for_completion:bool ->
Cmdliner_def.Arg_info.Set.t -> string list ->
[ `Ok of Cmdliner_def.Cline.t
| `Complete of Cmdliner_def.Complete.t * Cmdliner_def.Cline.t
| `Error of string * Cmdliner_def.Cline.t ]

52
unikernel/duniverse/cmdliner/src/cmdliner_cmd.ml Normal file
View file

@ -0,0 +1,52 @@
(*---------------------------------------------------------------------------
Copyright (c) 2022 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(* Commands *)
type info = Cmdliner_def.Cmd_info.t
let info = Cmdliner_def.Cmd_info.make
type 'a t =
| Cmd of info * 'a Cmdliner_term.parser
| Group of info * ('a Cmdliner_term.parser option * 'a t list)
let make info t =
let info = Cmdliner_def.Cmd_info.add_args info (Cmdliner_term.argset t) in
Cmd (info, Cmdliner_term.parser t)
let v = make
let get_info = function Cmd (info, _) | Group (info, _) -> info
let get_children_infos = function
| Cmd _ -> [] | Group (_, (_, cs)) -> List.map get_info cs
let group ?default info cmds =
let args, parser = match default with
| None -> None, None
| Some t -> Some (Cmdliner_term.argset t), Some (Cmdliner_term.parser t)
in
let children = List.map get_info cmds in
let info = Cmdliner_def.Cmd_info.with_children info ~args ~children in
Group (info, (parser, cmds))
let name c = Cmdliner_def.Cmd_info.name (get_info c)
let name_trie cmds =
let add acc cmd =
let info = get_info cmd in
let name = Cmdliner_def.Cmd_info.name info in
match Cmdliner_trie.add acc name cmd with
| `New t -> t
| `Replaced (cmd', _) ->
let info' = get_info cmd' and kind = "command" in
invalid_arg @@
Cmdliner_base.err_multi_def ~kind name
Cmdliner_def.Cmd_info.doc info info'
in
List.fold_left add Cmdliner_trie.empty cmds
let list_names cmds =
let cmd_name c = Cmdliner_def.Cmd_info.name (get_info c) in
List.sort String.compare (List.rev_map cmd_name cmds)

27
unikernel/duniverse/cmdliner/src/cmdliner_cmd.mli Normal file
View file

@ -0,0 +1,27 @@
(*---------------------------------------------------------------------------
Copyright (c) 2022 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(** Commands and their information. *)
type info = Cmdliner_def.Cmd_info.t
val info :
?deprecated:string -> ?man_xrefs:Cmdliner_manpage.xref list ->
?man:Cmdliner_manpage.block list -> ?envs:Cmdliner_def.Env.info list ->
?exits:Cmdliner_def.Exit.info list -> ?sdocs:string -> ?docs:string ->
?doc:string -> ?version:string -> string -> info
type 'a t =
| Cmd of info * 'a Cmdliner_term.parser
| Group of info * ('a Cmdliner_term.parser option * 'a t list)
val make : info -> 'a Cmdliner_term.t -> 'a t
val v : info -> 'a Cmdliner_term.t -> 'a t
val group : ?default:'a Cmdliner_term.t -> info -> 'a t list -> 'a t
val name : 'a t -> string
val name_trie : 'a t list -> 'a t Cmdliner_trie.t
val list_names : 'a t list -> string list
val get_info : 'a t -> info
val get_children_infos : 'a t -> info list

140
unikernel/duniverse/cmdliner/src/cmdliner_completion.ml Normal file
View file

@ -0,0 +1,140 @@
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(* Output protocol *)
let cons_if b v l = if b then v :: l else l
type directive =
| Dirs | Files | Group of string * (string * string) list
| Restart | Message of string
let pp_protocol ppf dirs =
let pp_line ppf s = Cmdliner_base.Fmt.(string ppf s; cut ppf ()) in
let pp_text ppf s = Cmdliner_base.Fmt.(pf ppf "@[%a@]@," styled_text s) in
let vnum = 1 (* Protocol version number *) in
let pp_item ppf (name, doc) =
pp_line ppf "item";
pp_line ppf name; pp_text ppf doc;
pp_line ppf "item-end";
in
let pp_dir ppf = function
| Dirs -> pp_line ppf "dirs"
| Files -> pp_line ppf "files"
| Restart -> pp_line ppf "restart"
| Group (name, items) ->
pp_line ppf "group";
pp_line ppf name;
Cmdliner_base.Fmt.(list ~sep:nop pp_item) ppf items;
| Message msg ->
pp_line ppf "message"; pp_text ppf msg; pp_line ppf "message-end"
in
Cmdliner_base.Fmt.pf ppf "@[<v>%d@,%a@]" vnum
Cmdliner_base.Fmt.(list ~sep:nop pp_dir) dirs
let add_subcommands_group ~err_ppf ~subst eval comp directives =
if not (Cmdliner_def.Complete.subcmds comp) then directives else
let prefix = Cmdliner_def.Complete.token comp in
let maybe_item cmd =
let name = Cmdliner_def.Cmd_info.name cmd in
if not (Cmdliner_base.string_starts_with ~prefix name) then None else
(* FIXME subst is wrong here. *)
let doc = Cmdliner_def.Cmd_info.styled_doc ~errs:err_ppf ~subst cmd in
Some (name, doc)
in
let subcmds = Cmdliner_def.Eval.subcmds eval in
Group ("Subcommands", List.filter_map maybe_item subcmds) :: directives
let add_options_group ~err_ppf ~subst eval comp directives =
let prefix = Cmdliner_def.Complete.token comp in
let maybe_items arg_info =
let names = Cmdliner_def.Arg_info.opt_names arg_info in
let subst = Cmdliner_def.Arg_info.doclang_subst ~subst arg_info in
let doc = Cmdliner_def.Arg_info.styled_doc ~errs:err_ppf ~subst arg_info in
let add_name n =
if not (Cmdliner_base.string_starts_with ~prefix n) then None else
Some (n, doc)
in
List.filter_map add_name names
in
let maybe_opt = prefix = "" || prefix.[0] = '-' in
if Cmdliner_def.Complete.after_dashdash comp || not maybe_opt
then directives else
let cmd_info = Cmdliner_def.Eval.cmd eval in
let set = Cmdliner_def.Cmd_info.args cmd_info in
if Cmdliner_def.Arg_info.Set.is_empty set then directives else
let options = Cmdliner_def.Arg_info.Set.elements set in
Group ("Options", List.concat (List.map maybe_items options)) :: directives
let add_argument_value_directives directives eval arg_info comp cline =
let (Conv conv) =
let arg_infos = Cmdliner_def.Cmd_info.args (Cmdliner_def.Eval.cmd eval) in
Option.get (Cmdliner_def.Arg_info.Set.find_opt arg_info arg_infos)
in
let value_dirs =
let completion = Cmdliner_def.Arg_conv.completion conv in
match Cmdliner_def.Arg_completion.complete completion with
| Complete (ctx, func) ->
let ctx = match ctx with
| None -> None
| Some ctx ->
match (Cmdliner_term.parser ctx) eval cline with
| Ok ctx -> Some ctx
| Error _ -> None
| exception exn -> None
in
func ctx ~token:(Cmdliner_def.Complete.token comp)
in
match value_dirs with
| Error msg -> `Directives [Message msg]
| Ok ds ->
let pp = Cmdliner_def.Arg_conv.pp conv in
let rec loop values msgs ~files ~dirs ~restart ~raw = function
| [] ->
begin match raw with
| Some r -> `Raw r
| None ->
if Cmdliner_def.Complete.after_dashdash comp && restart
then `Directives [Restart] else
let dd =
cons_if dirs Dirs @@
cons_if files Files @@
cons_if (values <> []) (Group ("Values", List.rev values)) []
in
`Directives (List.rev_append msgs (List.rev_append dd directives))
end
| d :: ds ->
match d with
| Cmdliner_def.Arg_completion.String (s, doc) ->
loop ((s, doc) :: values) msgs ~files ~dirs ~restart ~raw ds
| Value (v, doc) ->
let s = Cmdliner_base.Fmt.str "@[<h>%a@]" pp v in
loop ((s, doc) :: values) msgs ~files ~dirs ~restart ~raw ds
| Files -> loop values msgs ~files:true ~dirs ~restart ~raw ds
| Dirs -> loop values msgs ~files ~dirs:true ~restart ~raw ds
| Restart -> loop values msgs ~files ~dirs ~restart:true ~raw ds
| Message msg ->
loop values (Message msg :: msgs) ~files ~dirs ~restart ~raw ds
| Raw r -> loop values msgs ~files ~dirs ~restart ~raw:(Some r) ds
in
loop [] [] ~files:false ~dirs:false ~restart:false ~raw:None ds
let output ~out_ppf ~err_ppf eval comp cline =
let subst = Cmdliner_def.Eval.doclang_subst eval in
let dirs = add_subcommands_group ~err_ppf ~subst eval comp [] in
let res = match Cmdliner_def.Complete.kind comp with
| Opt_value arg_info ->
add_argument_value_directives dirs eval arg_info comp cline
| Opt_name_or_pos_value arg_info ->
let dirs = add_options_group ~err_ppf ~subst eval comp dirs in
add_argument_value_directives dirs eval arg_info comp cline
| Opt_name ->
`Directives (add_options_group ~err_ppf ~subst eval comp dirs)
in
if out_ppf == Format.std_formatter
then set_binary_mode_out stdout true;
match res with
| `Raw raw -> Cmdliner_base.Fmt.pf out_ppf "%s@?" raw
| `Directives dirs -> Cmdliner_base.Fmt.pf out_ppf "%a@?" pp_protocol dirs

9
unikernel/duniverse/cmdliner/src/cmdliner_completion.mli Normal file
View file

@ -0,0 +1,9 @@
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
val output :
out_ppf:Format.formatter -> err_ppf:Format.formatter ->
Cmdliner_def.Eval.t -> Cmdliner_def.Complete.t -> Cmdliner_def.Cline.t ->
unit

560
unikernel/duniverse/cmdliner/src/cmdliner_def.ml Normal file
View file

@ -0,0 +1,560 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
let strf = Printf.sprintf
(* Exit codes *)
module Exit = struct
type code = int
let ok = 0
let some_error = 123
let cli_error = 124
let internal_error = 125
type info =
{ codes : code * code; (* min, max *)
doc : string; (* help. *)
docs : string; } (* title of help section where listed. *)
let info
?(docs = Cmdliner_manpage.s_exit_status) ?(doc = "undocumented") ?max min
=
let max = match max with None -> min | Some max -> max in
{ codes = (min, max); doc; docs }
let info_codes i = i.codes
let info_code i = fst i.codes
let info_doc i = i.doc
let info_docs i = i.docs
let info_order i0 i1 = compare i0.codes i1.codes
let defaults =
[ info ok ~doc:"on success.";
info some_error
~doc:"on indiscriminate errors reported on standard error.";
info cli_error ~doc:"on command line parsing errors.";
info internal_error ~doc:"on unexpected internal errors (bugs)."; ]
let doclang_subst ~subst i = function
| "status" -> Some (string_of_int (info_code i))
| "status_max" -> Some (string_of_int (snd i.codes))
| id -> subst id
end
(* Environment variables *)
module Env = struct
type var = string
type info = (* information about an environment variable. *)
{ id : int; (* unique id for the env var. *)
deprecated : string option;
var : string; (* the variable. *)
doc : string; (* help. *)
docs : string; } (* title of help section where listed. *)
let info
?deprecated
?(docs = Cmdliner_manpage.s_environment) ?(doc = "See option $(opt).") var
=
{ id = Cmdliner_base.uid (); deprecated; var; doc; docs }
let info_deprecated i = i.deprecated
let info_var i = i.var
let info_doc i = i.doc
let info_docs i = i.docs
let info_compare i0 i1 = Int.compare i0.id i1.id
let doclang_subst ~subst i = function
| "env" -> Some (strf "$(b,%s)" (Cmdliner_manpage.escape i.var))
| id -> subst id
let styled_deprecated ~errs ~subst i = match i.deprecated with
| None -> "" | Some msg -> Cmdliner_manpage.doc_to_styled ~errs ~subst msg
let styled_doc ~errs ~subst i =
Cmdliner_manpage.doc_to_styled ~errs ~subst i.doc
module Set = Set.Make (struct type t = info let compare = info_compare end)
end
(* Argument information *)
module Arg_info = struct
type absence = Err | Val of string Lazy.t | Doc of string
type opt_kind = Flag | Opt | Opt_vopt of string
type pos_kind = (* information about a positional argument. *)
{ pos_rev : bool; (* if [true] positions are counted from the end. *)
pos_start : int; (* start positional argument. *)
pos_len : int option } (* number of arguments or [None] if unbounded. *)
let pos ~rev:pos_rev ~start:pos_start ~len:pos_len =
{ pos_rev; pos_start; pos_len}
let pos_rev p = p.pos_rev
let pos_start p = p.pos_start
let pos_len p = p.pos_len
let dumb_pos = pos ~rev:false ~start:(-1) ~len:None
type t = (* information about a command line argument. *)
{ id : int; (* unique id for the argument. *)
deprecated : string option; (* deprecation message *)
absent : absence; (* behaviour if absent. *)
env : Env.info option; (* environment variable for default value. *)
doc : string; (* help. *)
docv : string; (* variable name for the argument in help. *)
doc_envs : Env.info list; (* environment that needs to be added to docs *)
docs : string; (* title of help section where listed. *)
pos : pos_kind; (* positional arg kind. *)
opt_kind : opt_kind; (* optional arg kind. *)
opt_names : string list; (* names (for opt args). *)
opt_all : bool; } (* repeatable (for opt args). *)
let make
?deprecated ?(absent = "") ?docs ?(doc_envs = []) ?(docv = "")
?(doc = "") ?env names
=
let dash n = if String.length n = 1 then "-" ^ n else "--" ^ n in
let opt_names = List.map dash names in
let docs = match docs with
| Some s -> s
| None ->
match names with
| [] -> Cmdliner_manpage.s_arguments
| _ -> Cmdliner_manpage.s_options
in
{ id = Cmdliner_base.uid (); deprecated; absent = Doc absent;
env; doc; docv; doc_envs; docs; pos = dumb_pos;
opt_kind = Flag; opt_names; opt_all = false; }
let id i = i.id
let deprecated i = i.deprecated
let absent i = i.absent
let env i = i.env
let doc i = i.doc
let docv i = i.docv
let doc_envs i = i.doc_envs
let docs i = i.docs
let pos_kind i = i.pos
let opt_kind i = i.opt_kind
let opt_names i = i.opt_names
let opt_all i = i.opt_all
let opt_name_sample i =
(* First long or short name (in that order) in the list; this
allows the client to control which name is shown *)
let rec find = function
| [] -> List.hd i.opt_names
| n :: ns -> if (String.length n) > 2 then n else find ns
in
find i.opt_names
let make_req i = { i with absent = Err }
let make_all_opts i = { i with opt_all = true }
let make_opt ~docv ~absent ~kind:opt_kind i =
{ i with absent; opt_kind; docv }
let make_opt_all ~docv ~absent ~kind:opt_kind i =
{ i with absent; opt_kind; opt_all = true; docv }
let make_pos ~docv ~pos i = { i with pos; docv }
let make_pos_abs ~docv ~absent ~pos i = { i with absent; pos; docv }
let is_opt i = i.opt_names <> []
let is_pos i = i.opt_names = []
let is_req i = i.absent = Err
let pos_cli_order (a0 : t) (a1 : t) = (* best-effort order on the cli. *)
let c = Bool.compare (a0.pos.pos_rev) (a1.pos.pos_rev) in
if c <> 0 then c else
if a0.pos.pos_rev
then Int.compare a1.pos.pos_start a0.pos.pos_start
else Int.compare a0.pos.pos_start a1.pos.pos_start
let rev_pos_cli_order a0 a1 = pos_cli_order a1 a0
let doclang_subst ~subst (i : t) = function
| "docv" ->
let docv = if i.docv = "" then "VAL" else i.docv in
Some (strf "$(i,%s)" (Cmdliner_manpage.escape docv))
| "opt" when is_opt i ->
Some (strf "$(b,%s)" (Cmdliner_manpage.escape (opt_name_sample i)))
| id ->
match env i with
| Some e -> Env.doclang_subst ~subst e id
| None -> subst id
let styled_deprecated ~errs ~subst (i : t) = match i.deprecated with
| None -> "" | Some msg -> Cmdliner_manpage.doc_to_styled ~errs ~subst msg
let styled_doc ~errs ~subst (i : t) =
Cmdliner_manpage.doc_to_styled ~errs ~subst i.doc
let compare (a0 : t) (a1 : t) = Int.compare a0.id a1.id
module Map = Map.Make (struct type nonrec t = t let compare = compare end)
(* Due to terms appearing in the completion API, we have an annoying
recursive type definition which we resolve here. Most of these
types do not belong this module. *)
type term_escape =
[ `Error of bool * string
| `Help of Cmdliner_manpage.format * string option ]
type 'a completion_directive =
| Message of string | String of string * string | Value of 'a * string
| Files | Dirs | Restart | Raw of string
type ('ctx, 'a) completion_func =
'ctx option -> token:string -> ('a completion_directive list, string) result
type 'a parser = string -> ('a, string) result
type 'a complete =
| Complete : 'ctx term option * ('ctx, 'a) completion_func -> 'a complete
and 'a completion = { complete : 'a complete }
and 'a conv =
{ docv : string;
parser : 'a parser;
pp : 'a Cmdliner_base.Fmt.t;
completion : 'a completion; }
and e_conv = Conv : 'a conv -> e_conv
and arg_set = e_conv Map.t
and cmd =
{ name : string; (* name of the cmd. *)
version : string option; (* version (for --version). *)
deprecated : string option; (* deprecation message *)
doc : string; (* one line description of cmd. *)
docs : string; (* title of man section where listed (commands). *)
sdocs : string; (* standard options, title of section where listed. *)
exits : Exit.info list; (* exit codes for the cmd. *)
envs : Env.info list; (* env vars that influence the cmd. *)
man : Cmdliner_manpage.block list; (* man page text. *)
man_xrefs : Cmdliner_manpage.xref list; (* man cross-refs. *)
args : arg_set; (* Command arguments. *)
has_args : bool; (* [true] if has own parsing term. *)
children : cmd list; } (* Children, if any. *)
and eval = (* information about the evaluation context. *)
{ cmd : cmd; (* cmd being evaluated. *)
ancestors : cmd list; (* ancestors of cmd, root is last. *)
subcmds : cmd list; (* subcommands (if any) *)
env : string -> string option; (* environment variable lookup. *)
err_ppf : Format.formatter (* error formatter *) }
and cline = cline_arg Map.t
and cline_arg = (* unconverted argument data as found on the command line. *)
| O of (int * string * (string option)) list (* (pos, name, value) of opt. *)
| P of string list
and 'a term_parser =
eval -> cline -> ('a, [ `Parse of string | term_escape ]) result
and 'a term = arg_set * 'a term_parser
(* Sets of arguments stored as maps to their completion *)
module Set = struct
include Map
type t = e_conv Map.t
let find_opt k m = try Some (Map.find k m) with Not_found -> None
let elements m = List.map fst (bindings m)
let union a b =
Map.merge (fun k v v' ->
match v, v' with
| Some v, _ | _, Some v -> Some v
| None, None -> assert false) a b
end
end
(* Commands *)
module Cmd_info = struct
type t = Arg_info.cmd
let make
?deprecated ?(man_xrefs = [`Main]) ?(man = []) ?(envs = [])
?(exits = Exit.defaults) ?(sdocs = Cmdliner_manpage.s_common_options)
?(docs = Cmdliner_manpage.s_commands) ?(doc = "") ?version name : t
=
{ name; version; deprecated; doc; docs; sdocs; exits;
envs; man; man_xrefs; args = Arg_info.Set.empty;
has_args = true; children = [] }
let name (i : t) = i.name
let version (i : t) = i.version
let deprecated (i : t) = i.deprecated
let doc (i : t) = i.doc
let docs (i : t) = i.docs
let stdopts_docs (i : t) = i.sdocs
let exits (i : t) = i.exits
let envs (i : t) = i.envs
let man (i : t) = i.man
let man_xrefs (i : t) = i.man_xrefs
let args (i : t) = i.args
let has_args (i : t) = i.has_args
let children (i : t) = i.children
let add_args (i : t) args = { i with args = Arg_info.Set.union args i.args }
let with_children (i : t) ~args ~children =
let has_args, args = match args with
| None -> false, i.args
| Some args -> true, Arg_info.Set.union args i.args
in
{ i with has_args; args; children }
let styled_deprecated ~errs ~subst (i : t) = match i.deprecated with
| None -> "" | Some msg -> Cmdliner_manpage.doc_to_styled ~errs ~subst msg
let styled_doc ~errs ~subst (i : t) =
Cmdliner_manpage.doc_to_styled ~errs ~subst i.doc
let escaped_name (i : t) = Cmdliner_manpage.escape i.name
end
(* Command lines *)
module Cline = struct
type arg = Arg_info.cline_arg =
| O of (int * string * (string option)) list
| P of string list
type t = Arg_info.cline
let empty = Arg_info.Map.empty
let add = Arg_info.Map.add
let fold = Arg_info.Map.fold
let get_arg cline a : arg =
try Arg_info.Map.find a cline with Not_found -> assert false
let get_opt_arg cline a =
match get_arg cline a with O l -> l | _ -> assert false
let get_pos_arg cline a =
match get_arg cline a with P l -> l | _ -> assert false
let actual_args cline a = match get_arg cline a with
| P args -> args
| O l ->
let extract_args (_pos, name, value) =
name :: (match value with None -> [] | Some v -> [v])
in
List.concat (List.map extract_args l)
(* Deprecations *)
type deprecated = Arg_info.t * arg
let deprecated ~env cline =
let add ~env info arg acc =
let deprecation_invoked = match (arg : arg) with
| O [] | P [] -> (* nothing on the cli for the argument *)
begin match Arg_info.env info with
| None -> false
| Some ienv ->
(* the parse uses the env var if defined which may be
deprecated *)
Option.is_some (Env.info_deprecated ienv) &&
Option.is_some (env (Env.info_var ienv))
end
| _ -> Option.is_some (Arg_info.deprecated info)
in
if deprecation_invoked then (info, arg) :: acc else acc
in
List.rev (fold (add ~env) cline [])
let pp_deprecated ~subst ppf (info, arg) =
let open Cmdliner_base in
let plural l = if List.length l > 1 then "s" else "" in
let subst = Arg_info.doclang_subst ~subst info in
match (arg : arg) with
| O [] | P [] ->
let env = Option.get (Arg_info.env info) in
let msg = Env.styled_deprecated ~errs:ppf ~subst env in
Fmt.pf ppf "@[%a @[environment variable %a: %a@]@]"
Fmt.deprecated () Fmt.code (Env.info_var env)
Fmt.styled_text msg
| O os ->
let plural = plural os in
let names = List.map (fun (_, n, _) -> n) os in
let msg = Arg_info.styled_deprecated ~errs:ppf ~subst info in
Fmt.pf ppf "@[%a @[option%s %a: %a@]@]"
Fmt.deprecated () plural Fmt.(list ~sep:sp code_or_quote) names
Fmt.styled_text msg
| P args ->
let plural = plural args in
let msg =
Arg_info.styled_deprecated ~errs:ppf ~subst info
in
Fmt.pf ppf "@[%a @[argument%s %a: %a@]@]"
Fmt.deprecated () plural Fmt.(list ~sep:sp code_or_quote) args
Fmt.styled_text msg
end
(* Evaluation *)
module Eval = struct
type t = Arg_info.eval
let make ~ancestors ~cmd ~subcmds ~env ~err_ppf : t =
{ ancestors; cmd; subcmds; env; err_ppf }
let cmd (i : t) = i.cmd
let ancestors (i : t) = i.ancestors
let subcmds (i : t) = i.subcmds
let env_var (i : t) v = i.env v
let err_ppf (i : t) = i.err_ppf
let main (i : t) = match List.rev i.ancestors with [] -> i.cmd | m :: _ -> m
let with_cmd (i : t) cmd = { i with cmd }
let doclang_name n = strf "$(b,%s)" (Cmd_info.escaped_name n)
let doclang_names names =
strf "$(b,%s)" (Cmdliner_manpage.escape (String.concat " " names))
let doclang_subst (i : t) = function
| "tname" | "cmd.name" -> Some (doclang_name i.cmd)
| "mname" | "tool" -> Some (doclang_name (main i))
| "cmd.parent" ->
let ancestors = ancestors i in
if ancestors = [] then Some (doclang_name (main i)) else
Some (doclang_names (List.rev_map Cmd_info.name ancestors))
| "iname" | "cmd" ->
Some (doclang_names (List.rev_map Cmd_info.name (cmd i :: ancestors i)))
| _ -> None
end
(* Terms *)
module Term = struct
type escape = Arg_info.term_escape
type 'a parser = 'a Arg_info.term_parser
type 'a t = 'a Arg_info.term
let some (aset, parser) =
aset, (fun eval cline -> Result.map Option.some (parser eval cline))
end
module Arg_completion = struct
type 'a directive = 'a Arg_info.completion_directive =
| Message of string | String of string * string | Value of 'a * string
| Files | Dirs | Restart | Raw of string
let value ?(doc = "") v = Value (v, doc)
let string ?(doc = "") s = String (s, doc)
let files = Files
let dirs = Dirs
let restart = Restart
let message msg = Message msg
let raw s = Raw s
type ('ctx, 'a) func =
'ctx option -> token:string -> ('a directive list, string) result
type 'a complete = 'a Arg_info.complete =
| Complete : 'ctx Term.t option * ('ctx, 'a) func -> 'a complete
type 'a t = 'a Arg_info.completion
let make ?context func : 'a t = { complete = Complete (context, func) }
let complete (c : 'a t) = c.complete
let complete_files : 'a t =
{ complete = Complete (None, fun _ ~token:_ -> Ok [Files]) }
let complete_dirs : 'a t =
{ complete = Complete (None, fun _ ~token:_ -> Ok [Dirs]) }
let complete_paths : 'a t =
{ complete = Complete (None, fun _ ~token:_ -> Ok [Files; Dirs]) }
let complete_restart : 'a t =
{ complete = Complete (None, fun _ ~token:_ -> Ok [Restart]) }
let complete_none : 'a t =
{ complete = Complete (None, fun _ ~token:_ -> Ok []) }
let directive_some : 'a directive -> 'a option directive = function
| Value (v, doc) -> Value (Some v, doc)
| (Message _ | String _ | Files | Dirs | Restart | Raw _ as v) -> v
let complete_some (c : 'a t) : 'a option t = match c.complete with
| Complete (ctx, func) ->
let func ctx ~token =
let some_result directives = List.map directive_some directives in
Result.map some_result (func ctx ~token)
in
{ complete = Complete (ctx, func) }
end
(* Converters *)
module Arg_conv = struct
type 'a parser = 'a Arg_info.parser
type 'a fmt = 'a Cmdliner_base.Fmt.t
type 'a t = 'a Arg_info.conv
let make
?(completion = Arg_completion.complete_none) ~docv ~parser ~pp () : 'a t =
{ docv; parser; pp; completion }
let of_conv ?completion ?docv ?parser ?pp (conv : 'a t) : 'a t
=
let completion = Option.value ~default:conv.completion completion in
let docv = Option.value ~default:conv.docv docv in
let parser = Option.value ~default:conv.parser parser in
let pp = Option.value ~default:conv.pp pp in
{ docv; parser; pp; completion }
let docv (c : 'a t) = c.docv
let parser (c : 'a t) = c.parser
let pp (c : 'a t) = c.pp
let completion (c : 'a t) = c.completion
let none : 'a t =
{ docv = "";
parser = (fun _ -> assert false);
pp = (fun _ _ -> assert false);
completion = Arg_completion.complete_none }
let some ?(none = "") conv =
let parser s = Result.map Option.some (parser conv s) in
let pp ppf v = match v with
| None -> Format.pp_print_string ppf none
| Some v -> pp conv ppf v
in
let completion = Arg_completion.complete_some (completion conv) in
{ conv with parser; pp; completion }
let some' ?none conv =
let parser s = Result.map Option.some (parser conv s) in
let pp ppf = function
| None -> (match none with None -> () | Some v -> (pp conv) ppf v)
| Some v -> pp conv ppf v
in
let completion = Arg_completion.complete_some conv.completion in
{ conv with parser; pp; completion }
end
(* Completion *)
module Complete = struct
type kind =
| Opt_value of Arg_info.t
| Opt_name_or_pos_value of Arg_info.t
| Opt_name
type t =
{ token : string;
after_dashdash : bool;
subcmds : bool; (* Note this is adjusted in Cmdliner_eval *)
kind : kind }
let make ?(after_dashdash = false) ?(subcmds = false) ~token kind =
{ token; after_dashdash; subcmds; kind; }
let token c = c.token
let after_dashdash c = c.after_dashdash
let subcmds c = c.subcmds
let kind c = c.kind
let add_subcmds c = { c with subcmds = true }
end

304
unikernel/duniverse/cmdliner/src/cmdliner_def.mli Normal file
View file

@ -0,0 +1,304 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(** Core definitions. *)
(** Exit codes. *)
module Exit : sig
type code = int
val ok : code
val some_error : code
val cli_error : code
val internal_error : code
type info
val info : ?docs:string -> ?doc:string -> ?max:code -> code -> info
val info_code : info -> code
val info_codes : info -> code * code
val info_doc : info -> string
val info_docs : info -> string
val info_order : info -> info -> int
val defaults : info list
val doclang_subst :
subst:Cmdliner_manpage.subst -> info -> Cmdliner_manpage.subst
(** [doclang_subst ~subst info] adds the substitution of [info] to
[subst]. *)
end
(** Environment variables. *)
module Env : sig
type var = string
type info
val info : ?deprecated:string -> ?docs:string -> ?doc:string -> var -> info
val info_var : info -> string
val info_doc : info -> string
val info_docs : info -> string
val info_deprecated : info -> string option
val doclang_subst :
subst:Cmdliner_manpage.subst -> info -> Cmdliner_manpage.subst
(** [doclang_subst ~subst info] adds the substitution of [info] to
[subst]. *)
val styled_deprecated :
errs:Format.formatter -> subst:Cmdliner_manpage.subst -> info -> string
val styled_doc :
errs:Format.formatter -> subst:Cmdliner_manpage.subst -> info -> string
module Set : Set.S with type elt = info
end
(** Argument information. *)
module Arg_info : sig
type absence =
| Err (** an error is reported. *)
| Val of string Lazy.t (** if <> "", takes the given default value. *)
| Doc of string
(** if <> "", a doc string interpreted in the doc markup language. *)
(** The type for what happens if the argument is absent from the cli. *)
type opt_kind =
| Flag (** without value, just a flag. *)
| Opt (** with required value. *)
| Opt_vopt of string (** with optional value, takes given default. *)
(** The type for optional argument kinds. *)
type pos_kind
val pos : rev:bool -> start:int -> len:int option -> pos_kind
val pos_rev : pos_kind -> bool
val pos_start : pos_kind -> int
val pos_len : pos_kind -> int option
type t
val make :
?deprecated:string -> ?absent:string -> ?docs:string ->
?doc_envs:Env.info list -> ?docv:string -> ?doc:string ->
?env:Env.info -> string list -> t
val id : t -> int
val deprecated : t -> string option
val absent : t -> absence
val env : t -> Env.info option
val doc : t -> string
val docv : t -> string
val doc_envs : t -> Env.info list
val docs : t -> string
val opt_names : t -> string list (* has dashes *)
val opt_name_sample : t -> string (* warning must be an opt arg *)
val opt_kind : t -> opt_kind
val pos_kind : t -> pos_kind
val make_req : t -> t
val make_all_opts : t -> t
val make_opt : docv:string -> absent:absence -> kind:opt_kind -> t -> t
val make_opt_all : docv:string -> absent:absence -> kind:opt_kind -> t -> t
val make_pos : docv:string -> pos:pos_kind -> t -> t
val make_pos_abs : docv:string -> absent:absence -> pos:pos_kind -> t -> t
val is_opt : t -> bool
val is_pos : t -> bool
val is_req : t -> bool
val pos_cli_order : t -> t -> int
val rev_pos_cli_order : t -> t -> int
val compare : t -> t -> int
val doclang_subst :
subst:Cmdliner_manpage.subst -> t -> Cmdliner_manpage.subst
(** [doclang_subst ~subst info] adds the substitution of [info] to
[subst]. Note this includes the substitutions for [env] if present. *)
val styled_deprecated :
errs:Format.formatter -> subst:Cmdliner_manpage.subst -> t -> string
val styled_doc :
errs:Format.formatter -> subst:Cmdliner_manpage.subst -> t -> string
type 'a conv
type e_conv = Conv : 'a conv -> e_conv
module Set : sig
type arg := t
type t
val is_empty : t -> bool
val empty : t
val add : arg -> e_conv -> t -> t
val choose : t -> arg * e_conv
val partition : (arg -> e_conv -> bool) -> t -> t * t
val filter : (arg -> e_conv -> bool) -> t -> t
val iter : (arg -> e_conv -> unit) -> t -> unit
val singleton : arg -> e_conv -> t
val fold : (arg -> e_conv -> 'acc -> 'acc) -> t -> 'acc -> 'acc
val elements : t -> arg list
val union : t -> t -> t
val find_opt : arg -> t -> e_conv option
end
end
(** Command information. *)
module Cmd_info : sig
type t
val make :
?deprecated:string -> ?man_xrefs:Cmdliner_manpage.xref list ->
?man:Cmdliner_manpage.block list -> ?envs:Env.info list ->
?exits:Exit.info list -> ?sdocs:string -> ?docs:string -> ?doc:string ->
?version:string -> string -> t
val name : t -> string
val version : t -> string option
val deprecated : t -> string option
val doc : t -> string
val docs : t -> string
val stdopts_docs : t -> string
val exits : t -> Exit.info list
val envs : t -> Env.info list
val man : t -> Cmdliner_manpage.block list
val man_xrefs : t -> Cmdliner_manpage.xref list
val args : t -> Arg_info.Set.t
val has_args : t -> bool
val children : t -> t list
val add_args : t -> Arg_info.Set.t -> t
val with_children : t -> args:Arg_info.Set.t option -> children:t list -> t
val styled_deprecated :
errs:Format.formatter -> subst:Cmdliner_manpage.subst -> t -> string
val styled_doc :
errs:Format.formatter -> subst:Cmdliner_manpage.subst -> t -> string
end
(** Untyped command line parses. *)
module Cline : sig
type arg =
| O of (int * string * (string option)) list (* (pos, name, value) of opt. *)
| P of string list (** *)
(** Unconverted argument data as found on the command line. *)
type t (* command line, maps arg_infos to arg value. *)
val empty : t
val add : Arg_info.t -> arg -> t -> t
val get_arg : t -> Arg_info.t -> arg
val get_opt_arg : t -> Arg_info.t -> (int * string * (string option)) list
val get_pos_arg : t -> Arg_info.t -> string list
val actual_args : t -> Arg_info.t -> string list
(** Actual command line arguments from the command line *)
val fold : (Arg_info.t -> arg -> 'b -> 'b) -> t -> 'b -> 'b
(** {1:deprecations Deprecations} *)
type deprecated
(** The type for deprecation invocations. This include both environment
variable deprecations and argument deprecations. *)
val deprecated :
env:(string -> string option) -> t -> deprecated list
(** [deprecated ~env cli] are the deprecated invocations that occur
when parsing [cli]. *)
val pp_deprecated :
subst:Cmdliner_manpage.subst -> deprecated Cmdliner_base.Fmt.t
(** [pp_deprecated] formats deprecations. *)
end
(** Evaluation. *)
module Eval : sig
type t
val make :
ancestors:Cmd_info.t list -> cmd:Cmd_info.t -> subcmds:Cmd_info.t list ->
env:(string -> string option) -> err_ppf:Format.formatter -> t
val cmd : t -> Cmd_info.t
val main : t -> Cmd_info.t
val ancestors : t -> Cmd_info.t list (* root is last *)
val subcmds : t -> Cmd_info.t list
val env_var : t -> string -> string option
val err_ppf : t -> Format.formatter
val with_cmd : t -> Cmd_info.t -> t
val doclang_subst : t -> Cmdliner_manpage.subst
end
(** Terms, typed cli fragment definitions. *)
module Term : sig
type escape =
[ `Error of bool * string
| `Help of Cmdliner_manpage.format * string option ]
type 'a parser =
Eval.t -> Cline.t -> ('a, [ `Parse of string | escape ]) result
type 'a t = Arg_info.Set.t * 'a parser
end
(** Completion strategies *)
module Arg_completion : sig
type 'a directive =
| Message of string | String of string * string | Value of 'a * string
| Files | Dirs | Restart | Raw of string
val value : ?doc:string -> 'a -> 'a directive
val string : ?doc:string -> string -> 'a directive
val files : 'a directive
val dirs : 'a directive
val restart : 'a directive
val message : string -> 'a directive
val raw : string -> 'a directive
type ('ctx, 'a) func =
'ctx option -> token:string -> ('a directive list, string) result
type 'a complete =
| Complete : 'ctx Term.t option * ('ctx, 'a) func -> 'a complete
type 'a t
val make : ?context:'ctx Term.t -> ('ctx, 'a) func -> 'a t
val complete : 'a t -> 'a complete
val complete_none : 'a t
val complete_files : 'a t
val complete_dirs : 'a t
val complete_paths : 'a t
val complete_restart : 'a t
end
(** Textual OCaml value converters *)
module Arg_conv : sig
type 'a parser = string -> ('a, string) result
type 'a fmt = 'a Cmdliner_base.Fmt.t
type 'a t = 'a Arg_info.conv
val make :
?completion:'a Arg_completion.t -> docv:string -> parser:'a parser ->
pp:'a fmt -> unit -> 'a t
val of_conv :
?completion:'a Arg_completion.t -> ?docv:string ->
?parser:'a parser -> ?pp:'a fmt -> 'a t -> 'a t
val docv : 'a t -> string
val parser : 'a t -> 'a parser
val pp : 'a t -> 'a fmt
val completion : 'a t -> 'a Arg_completion.t
val some : ?none:string -> 'a t -> 'a option t
val some' : ?none:'a -> 'a t -> 'a option t
val none : 'a t
end
(** Complete instruction. *)
module Complete : sig
type kind =
| Opt_value of Arg_info.t
| Opt_name_or_pos_value of Arg_info.t
| Opt_name
type t
val make : ?after_dashdash:bool -> ?subcmds:bool -> token:string -> kind -> t
val token : t -> string
val after_dashdash : t -> bool
val subcmds : t -> bool
val kind : t -> kind
val add_subcmds : t -> t
end

393
unikernel/duniverse/cmdliner/src/cmdliner_docgen.ml Normal file
View file

@ -0,0 +1,393 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
let rev_compare n0 n1 = compare n1 n0
let strf = Printf.sprintf
let order_args a0 a1 =
match Cmdliner_def.Arg_info.is_opt a0, Cmdliner_def.Arg_info.is_opt a1 with
| true, true -> (* optional by name *)
let key names =
let k = List.hd (List.sort rev_compare names) in
let k = String.lowercase_ascii k in
if k.[1] = '-' then String.sub k 1 (String.length k - 1) else k
in
compare
(key @@ Cmdliner_def.Arg_info.opt_names a0)
(key @@ Cmdliner_def.Arg_info.opt_names a1)
| false, false -> (* positional by variable *)
compare
(String.lowercase_ascii @@ Cmdliner_def.Arg_info.docv a0)
(String.lowercase_ascii @@ Cmdliner_def.Arg_info.docv a1)
| true, false -> -1 (* positional first *)
| false, true -> 1 (* optional after *)
let esc = Cmdliner_manpage.escape
let sorted_items_to_blocks ~boilerplate:b items =
(* Items are sorted by section and then rev. sorted by appearance.
We gather them by section in correct order in a `Block and prefix
them with optional boilerplate *)
let boilerplate = match b with None -> (fun _ -> None) | Some b -> b in
let mk_block sec acc = match boilerplate sec with
| None -> (sec, `Blocks acc)
| Some b -> (sec, `Blocks (b :: acc))
in
let rec loop secs sec acc = function
| (sec', it) :: its when sec' = sec -> loop secs sec (it :: acc) its
| (sec', it) :: its -> loop (mk_block sec acc :: secs) sec' [it] its
| [] -> (mk_block sec acc) :: secs
in
match items with
| [] -> []
| (sec, it) :: its -> loop [] sec [it] its
(* Command docs *)
let invocation ?(sep = " ") ?(ancestors = []) cmd =
let names = List.rev_map Cmdliner_def.Cmd_info.name (cmd :: ancestors) in
esc @@ String.concat sep names
let synopsis_pos_arg a =
let v = match Cmdliner_def.Arg_info.docv a with "" -> "ARG" | v -> v in
let v = strf "$(i,%s)" (esc v) in
let v =
(if Cmdliner_def.Arg_info.is_req a then strf "%s" else strf "[%s]") v
in
match Cmdliner_def.Arg_info.(pos_len @@ pos_kind a) with
| None -> v ^ "…"
| Some 1 -> v
| Some n ->
let rec loop n acc = if n <= 0 then acc else loop (n - 1) (v :: acc) in
String.concat " " (loop n [])
let synopsis_opt_arg a n =
let var = match Cmdliner_def.Arg_info.docv a with "" -> "VAL" | v -> v in
match Cmdliner_def.Arg_info.opt_kind a with
| Cmdliner_def.Arg_info.Flag -> strf "$(b,%s)" (esc n)
| Cmdliner_def.Arg_info.Opt ->
if String.length n > 2
then strf "$(b,%s)=$(i,%s)" (esc n) (esc var)
else strf "$(b,%s) $(i,%s)" (esc n) (esc var)
| Cmdliner_def.Arg_info.Opt_vopt _ ->
if String.length n > 2
then strf "$(b,%s)[=$(i,%s)]" (esc n) (esc var)
else strf "$(b,%s) [$(i,%s)]" (esc n) (esc var)
let deprecated cmd = match Cmdliner_def.Cmd_info.deprecated cmd with
| None -> "" | Some _ -> "(Deprecated) "
let synopsis ?(show_help = false) ?ancestors cmd =
let show_help = if show_help then " [$(b,--help)]" else "" in
match Cmdliner_def.Cmd_info.children cmd with
| [] ->
let rev_cli_order (a0, _) (a1, _) =
Cmdliner_def.Arg_info.rev_pos_cli_order a0 a1
in
let args = Cmdliner_def.Cmd_info.args cmd in
let oargs, pargs =
Cmdliner_def.Arg_info.(Set.partition (fun a _ -> is_opt a) args)
in
let oargs =
(* Keep only those that are listed in the s_options section and
that are not [--version] or [--help]. * *)
let keep a _ =
let drop_names n = n = "--help" || n = "--version" in
Cmdliner_def.Arg_info.docs a = Cmdliner_manpage.s_options &&
not (List.exists drop_names (Cmdliner_def.Arg_info.opt_names a))
in
let oargs = Cmdliner_def.Arg_info.Set.(elements (filter keep oargs)) in
let count = List.length oargs in
let any_option = "[$(i,OPTION)]…" in
if count = 0 || count > 3 then any_option else
let syn a =
let syn =
synopsis_opt_arg a (Cmdliner_def.Arg_info.opt_name_sample a)
in
if Cmdliner_def.Arg_info.is_req a
then syn
else strf "[%s]" syn
in
let oargs = List.sort order_args oargs in
let oargs = String.concat " " (List.map syn oargs) in
String.concat " " [oargs; any_option]
in
let pargs =
let pargs = Cmdliner_def.Arg_info.Set.elements pargs in
if pargs = [] then "" else
let pargs = List.map (fun a -> a, synopsis_pos_arg a) pargs in
let pargs = List.sort rev_cli_order pargs in
String.concat " " ("" (* add a space *) :: List.rev_map snd pargs)
in
strf "%s$(b,%s)%s %s%s"
(deprecated cmd) (invocation ?ancestors cmd) show_help oargs pargs
| _cmds ->
let subcmd = match Cmdliner_def.Cmd_info.has_args cmd with
| false -> "$(i,COMMAND)" | true -> "[$(i,COMMAND)]"
in
strf "%s$(b,%s)%s %s …" (deprecated cmd) (invocation ?ancestors cmd)
show_help subcmd
let cmd_doc cmd =
let depr = match Cmdliner_def.Cmd_info.deprecated cmd with
| None -> "" | Some msg -> msg ^ " "
in
depr ^ Cmdliner_def.Cmd_info.doc cmd
let cmd_docs ei = match Cmdliner_def.(Cmd_info.children (Eval.cmd ei)) with
| [] -> []
| cmds ->
let add_cmd acc cmd =
let syn = synopsis cmd in
(Cmdliner_def.Cmd_info.docs cmd, `I (syn, cmd_doc cmd)) :: acc
in
let by_sec_by_rev_name (s0, `I (c0, _)) (s1, `I (c1, _)) =
let c = compare s0 s1 in
if c <> 0 then c else compare c1 c0 (* N.B. reverse *)
in
let cmds = List.fold_left add_cmd [] cmds in
let cmds = List.sort by_sec_by_rev_name cmds in
let cmds = (cmds :> (string * Cmdliner_manpage.block) list) in
sorted_items_to_blocks ~boilerplate:None cmds
(* Argument docs *)
let arg_man_item_label a =
let s = match Cmdliner_def.Arg_info.is_pos a with
| true -> strf "$(i,%s)" (esc @@ Cmdliner_def.Arg_info.docv a)
| false ->
let names = List.sort compare (Cmdliner_def.Arg_info.opt_names a) in
String.concat ", " (List.rev_map (synopsis_opt_arg a) names)
in
match Cmdliner_def.Arg_info.deprecated a with
| None -> s | Some _ -> "(Deprecated) " ^ s
let arg_to_man_item ~errs ~subst ~buf a =
let subst = Cmdliner_def.Arg_info.doclang_subst ~subst a in
let or_env ~value a = match Cmdliner_def.Arg_info.env a with
| None -> ""
| Some e ->
let value = if value then " or" else "absent " in
strf "%s $(b,%s) env" value (esc @@ Cmdliner_def.Env.info_var e)
in
let absent = match Cmdliner_def.Arg_info.absent a with
| Cmdliner_def.Arg_info.Err -> "required"
| Cmdliner_def.Arg_info.Doc "" -> strf "%s" (or_env ~value:false a)
| Cmdliner_def.Arg_info.Doc s ->
let s = Cmdliner_manpage.subst_vars ~errs ~subst buf s in
strf "absent=%s%s" s (or_env ~value:true a)
| Cmdliner_def.Arg_info.Val v ->
match Lazy.force v with
| "" -> strf "%s" (or_env ~value:false a)
| v -> strf "absent=$(b,%s)%s" (esc v) (or_env ~value:true a)
in
let optvopt = match Cmdliner_def.Arg_info.opt_kind a with
| Cmdliner_def.Arg_info.Opt_vopt v -> strf "default=$(b,%s)" (esc v)
| _ -> ""
in
let argvdoc = match optvopt, absent with
| "", "" -> ""
| s, "" | "", s -> strf " (%s)" s
| s, s' -> strf " (%s) (%s)" s s'
in
let deprecated = match Cmdliner_def.Arg_info.deprecated a with
| None -> "" | Some msg -> msg ^ " "
in
let doc = deprecated ^ Cmdliner_def.Arg_info.doc a in
let doc = Cmdliner_manpage.subst_vars ~errs ~subst buf doc in
(Cmdliner_def.Arg_info.docs a, `I (arg_man_item_label a ^ argvdoc, doc))
let arg_docs ~errs ~subst ~buf ei =
let by_sec_by_arg a0 a1 =
let c = compare
(Cmdliner_def.Arg_info.docs a0)
(Cmdliner_def.Arg_info.docs a1)
in
if c <> 0 then c else
let c =
match
Cmdliner_def.Arg_info.deprecated a0,
Cmdliner_def.Arg_info.deprecated a1
with
| None, None | Some _, Some _ -> 0
| None, Some _ -> -1 | Some _, None -> 1
in
if c <> 0 then c else order_args a0 a1
in
let keep_arg a _ acc =
if not Cmdliner_def.Arg_info.(is_pos a && (docv a = "" || doc a = ""))
then (a :: acc) else acc
in
let args = Cmdliner_def.Cmd_info.args @@ Cmdliner_def.Eval.cmd ei in
let args = Cmdliner_def.Arg_info.Set.fold keep_arg args [] in
let args = List.sort by_sec_by_arg args in
let args = List.rev_map (arg_to_man_item ~errs ~subst ~buf) args in
sorted_items_to_blocks ~boilerplate:None args
(* Exit statuses doc *)
let exit_boilerplate sec = match sec = Cmdliner_manpage.s_exit_status with
| false -> None
| true -> Some (Cmdliner_manpage.s_exit_status_intro)
let exit_docs ~errs ~subst ~buf ~has_sexit ei =
let by_sec (s0, _) (s1, _) = compare s0 s1 in
let add_exit_item acc einfo =
let subst = Cmdliner_def.Exit.doclang_subst ~subst einfo in
let min, max = Cmdliner_def.Exit.info_codes einfo in
let doc = Cmdliner_def.Exit.info_doc einfo in
let label = if min = max then strf "%d" min else strf "%d-%d" min max in
let item = `I (label, Cmdliner_manpage.subst_vars ~errs ~subst buf doc) in
(Cmdliner_def.Exit.info_docs einfo, item) :: acc
in
let exits = Cmdliner_def.Cmd_info.exits @@ Cmdliner_def.Eval.cmd ei in
let exits = List.sort Cmdliner_def.Exit.info_order exits in
let exits = List.fold_left add_exit_item [] exits in
let exits = List.stable_sort by_sec (* sort by section *) exits in
let boilerplate = if has_sexit then None else Some exit_boilerplate in
sorted_items_to_blocks ~boilerplate exits
(* Environment doc *)
let env_boilerplate sec = match sec = Cmdliner_manpage.s_environment with
| false -> None
| true -> Some (Cmdliner_manpage.s_environment_intro)
let env_docs ~errs ~subst ~buf ~has_senv ei =
let add_env_item ~subst (seen, envs as acc) e =
if Cmdliner_def.Env.Set.mem e seen then acc else
let seen = Cmdliner_def.Env.Set.add e seen in
let var = strf "$(b,%s)" @@ esc (Cmdliner_def.Env.info_var e) in
let var, deprecated = match Cmdliner_def.Env.info_deprecated e with
| None -> var, "" | Some msg -> "(Deprecated) " ^ var, msg ^ " " in
let doc = deprecated ^ Cmdliner_def.Env.info_doc e in
let doc = Cmdliner_manpage.subst_vars ~errs ~subst buf doc in
let envs = (Cmdliner_def.Env.info_docs e, `I (var, doc)) :: envs in
seen, envs
in
let add_arg_envs a _ acc =
let envs = Cmdliner_def.Arg_info.doc_envs a in
let envs = match Cmdliner_def.Arg_info.env a with
| None -> envs | Some e -> e :: envs
in
let subst = Cmdliner_def.Arg_info.doclang_subst ~subst a in
List.fold_left (add_env_item ~subst) acc envs
in
let add_env acc e =
let subst = Cmdliner_def.Env.doclang_subst ~subst e in
add_env_item ~subst acc e
in
let by_sec_by_rev_name (s0, `I (v0, _)) (s1, `I (v1, _)) =
let c = compare s0 s1 in
if c <> 0 then c else compare v1 v0 (* N.B. reverse *)
in
(* Arg envs before term envs is important here: if the same is mentioned
both in an arg and in a term the substs of the arg are allowed. *)
let args = Cmdliner_def.Cmd_info.args @@ Cmdliner_def.Eval.cmd ei in
let tenvs = Cmdliner_def.Cmd_info.envs @@ Cmdliner_def.Eval.cmd ei in
let init = Cmdliner_def.Env.Set.empty, [] in
let acc = Cmdliner_def.Arg_info.Set.fold add_arg_envs args init in
let _, envs = List.fold_left add_env acc tenvs in
let envs = List.sort by_sec_by_rev_name envs in
let envs = (envs :> (string * Cmdliner_manpage.block) list) in
let boilerplate = if has_senv then None else Some env_boilerplate in
sorted_items_to_blocks ~boilerplate envs
(* xref doc *)
let xref_docs ~errs ei =
let main = Cmdliner_def.Eval.main ei in
let to_xref = function
| `Main -> Cmdliner_def.Cmd_info.name main, 1
| `Tool tool -> tool, 1
| `Page (name, sec) -> name, sec
| `Cmd c ->
(* N.B. we are handling only the first subcommand level here *)
let cmds = Cmdliner_def.Cmd_info.children main in
let mname = Cmdliner_def.Cmd_info.name main in
let is_cmd cmd = Cmdliner_def.Cmd_info.name cmd = c in
if List.exists is_cmd cmds then strf "%s-%s" mname c, 1 else
(Format.fprintf errs "xref %s: no such command name@." c; "doc-err", 0)
in
let xref_str (name, sec) = strf "%s(%d)" (esc name) sec in
let xrefs = Cmdliner_def.Cmd_info.man_xrefs @@ Cmdliner_def.Eval.cmd ei in
let xrefs = match main == Cmdliner_def.Eval.cmd ei with
| true -> List.filter (fun x -> x <> `Main) xrefs (* filter out default *)
| false -> xrefs
in
let xrefs = List.fold_left (fun acc x -> to_xref x :: acc) [] xrefs in
let xrefs = List.(rev_map xref_str (sort rev_compare xrefs)) in
if xrefs = [] then [] else
[Cmdliner_manpage.s_see_also, `P (String.concat ", " xrefs)]
(* Man page construction *)
let ensure_s_name ei sm =
if Cmdliner_manpage.(smap_has_section sm ~sec:s_name) then sm else
let cmd = Cmdliner_def.Eval.cmd ei in
let ancestors = Cmdliner_def.Eval.ancestors ei in
let tname = (deprecated cmd) ^ invocation ~sep:"-" ~ancestors cmd in
let tdoc = cmd_doc cmd in
let tagline = if tdoc = "" then "" else strf " - %s" tdoc in
let tagline = `P (strf "%s%s" tname tagline) in
Cmdliner_manpage.(smap_append_block sm ~sec:s_name tagline)
let ensure_s_synopsis ei sm =
if Cmdliner_manpage.(smap_has_section sm ~sec:s_synopsis) then sm else
let cmd = Cmdliner_def.Eval.cmd ei in
let ancestors = Cmdliner_def.Eval.ancestors ei in
let synopsis = `P (synopsis ~ancestors cmd) in
Cmdliner_manpage.(smap_append_block sm ~sec:s_synopsis synopsis)
let insert_cmd_man_docs ~errs ei sm =
let buf = Buffer.create 200 in
let subst = Cmdliner_def.Eval.doclang_subst ei in
let ins sm (sec, b) = Cmdliner_manpage.smap_append_block sm ~sec b in
let has_senv = Cmdliner_manpage.(smap_has_section sm ~sec:s_environment) in
let has_sexit = Cmdliner_manpage.(smap_has_section sm ~sec:s_exit_status) in
let sm = List.fold_left ins sm (cmd_docs ei) in
let sm = List.fold_left ins sm (arg_docs ~errs ~subst ~buf ei) in
let sm = List.fold_left ins sm (exit_docs ~errs ~subst ~buf ~has_sexit ei)in
let sm = List.fold_left ins sm (env_docs ~errs ~subst ~buf ~has_senv ei) in
let sm = List.fold_left ins sm (xref_docs ~errs ei) in
sm
let text ~errs ei =
let man = Cmdliner_def.Cmd_info.man @@ Cmdliner_def.Eval.cmd ei in
let sm = Cmdliner_manpage.smap_of_blocks man in
let sm = ensure_s_name ei sm in
let sm = ensure_s_synopsis ei sm in
let sm = insert_cmd_man_docs ei ~errs sm in
Cmdliner_manpage.smap_to_blocks sm
let title ei =
let main = Cmdliner_def.Eval.main ei in
let exec = String.capitalize_ascii (Cmdliner_def.Cmd_info.name main) in
let cmd = Cmdliner_def.Eval.cmd ei in
let ancestors = Cmdliner_def.Eval.ancestors ei in
let name = String.uppercase_ascii (invocation ~sep:"-" ~ancestors cmd) in
let center_header = esc @@ strf "%s Manual" exec in
let left_footer =
let version = match Cmdliner_def.Cmd_info.version main with
| None -> "" | Some v -> " " ^ v
in
esc @@ strf "%s%s" exec version
in
name, 1, "", left_footer, center_header
let man ~errs ei = title ei, text ~errs ei
let pp_man ~env ~errs fmt ppf ei =
let subst = Cmdliner_def.Eval.doclang_subst ei in
Cmdliner_manpage.print ~env ~errs ~subst fmt ppf (man ~errs ei)
(* Plain synopsis for usage *)
let styled_usage_synopsis ~errs ei =
let subst = Cmdliner_def.Eval.doclang_subst ei in
let cmd = Cmdliner_def.Eval.cmd ei in
let ancestors = Cmdliner_def.Eval.ancestors ei in
let synopsis = synopsis ~show_help:true ~ancestors cmd in
Cmdliner_manpage.doc_to_styled ~errs ~subst synopsis

12
unikernel/duniverse/cmdliner/src/cmdliner_docgen.mli Normal file
View file

@ -0,0 +1,12 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
val pp_man :
env:(string -> string option) ->
errs:Format.formatter -> Cmdliner_manpage.format -> Format.formatter ->
Cmdliner_def.Eval.t -> unit
val styled_usage_synopsis :
errs:Format.formatter -> Cmdliner_def.Eval.t -> string

349
unikernel/duniverse/cmdliner/src/cmdliner_eval.ml Normal file
View file

@ -0,0 +1,349 @@
(*---------------------------------------------------------------------------
Copyright (c) 2022 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
type 'a eval_ok = [ `Ok of 'a | `Version | `Help ]
type eval_error = [ `Parse | `Term | `Exn ]
type 'a eval_exit = [ `Ok of 'a | `Exit of Cmdliner_def.Exit.code ]
type eval_result_error =
[ Cmdliner_term.term_escape
| `Exn of exn * Printexc.raw_backtrace
| `Parse of string
| `Std_help of Cmdliner_manpage.format
| `Std_version ]
type 'a eval_result =
('a, [ eval_result_error
| `Complete of Cmdliner_def.Complete.t * Cmdliner_def.Cline.t]) result
let err_help s = "Term error, help requested for unknown command " ^ s
let err_argv = "argv array must have at least one element"
let add_stdopts eval =
let docs = Cmdliner_def.Cmd_info.stdopts_docs (Cmdliner_def.Eval.cmd eval) in
let vargs, vers =
match Cmdliner_def.Cmd_info.version (Cmdliner_def.Eval.main eval) with
| None -> Cmdliner_def.Arg_info.Set.empty, None
| Some _ ->
let vers = Cmdliner_arg.stdopt_version ~docs in
(Cmdliner_term.argset vers), Some vers
in
let help = Cmdliner_arg.stdopt_help ~docs in
let args =
Cmdliner_def.Arg_info.Set.union vargs (Cmdliner_term.argset help)
in
let cmd = Cmdliner_def.Cmd_info.add_args (Cmdliner_def.Eval.cmd eval) args in
help, vers, Cmdliner_def.Eval.with_cmd eval cmd
let run_parser ~catch eval cl f =
try (f eval cl :> ('a, eval_result_error) result) with
| exn when catch ->
let bt = Printexc.get_raw_backtrace () in
Error (`Exn (exn, bt))
let try_eval_stdopts ~catch eval cline help version : 'a eval_result option =
match run_parser ~catch eval cline (Cmdliner_term.parser help) with
| Ok (Some fmt) -> Some (Error (`Std_help fmt))
| Error (`Parse _) ->
(* only [FMT] errored, there was a `--help`, show help anyways *)
Some (Error (`Std_help `Auto))
| Error _ as err -> (Some err :> 'a eval_result option)
| Ok None ->
match version with
| None -> None
| Some version ->
match (run_parser ~catch eval cline (Cmdliner_term.parser version))
with
| Ok false -> None
| Ok true -> Some (Error (`Std_version))
| Error _ as err -> (Some err :> 'a eval_result option)
let do_help ~env help_ppf err_ppf eval fmt cmd_name =
let eval = match cmd_name with
| None (* help of main command requested *) ->
let env _ = assert false in
let cmd = Cmdliner_def.Eval.main eval in
let subcmds = Cmdliner_def.Eval.subcmds eval in
let eval' =
Cmdliner_def.Eval.make ~ancestors:[] ~cmd ~subcmds ~env ~err_ppf
in
begin match Cmdliner_def.Eval.ancestors eval with
| [] -> (* [ei] is an evaluation of main, [cmd] has stdopts *) eval'
| _ -> let _, _, eval' = add_stdopts eval' in eval'
end
| Some cmd ->
try
(* For now we simply keep backward compat. [cmd] should be
a name from main's children. *)
let main = Cmdliner_def.Eval.main eval in
let is_cmd t = Cmdliner_def.Cmd_info.name t = cmd in
let children = Cmdliner_def.Cmd_info.children main in
let cmd = List.find is_cmd children in
let _, _, eval = add_stdopts (Cmdliner_def.Eval.with_cmd eval cmd) in
eval
with Not_found -> invalid_arg (err_help cmd)
in
Cmdliner_docgen.pp_man ~env ~errs:err_ppf fmt help_ppf eval
let do_result ~env help_ppf err_ppf eval = function
| Ok v -> Ok (`Ok v)
| Error res ->
match res with
| `Std_help fmt ->
Cmdliner_docgen.pp_man ~env ~errs:err_ppf fmt help_ppf eval; Ok `Help
| `Std_version ->
Cmdliner_msg.pp_version help_ppf eval; Ok `Version
| `Parse err ->
Cmdliner_msg.pp_usage_and_err err_ppf eval ~err; Error `Parse
| `Complete (comp, cline) ->
Cmdliner_completion.output ~out_ppf:help_ppf ~err_ppf eval comp cline;
Ok `Help
| `Help (fmt, cmd_name) ->
do_help ~env help_ppf err_ppf eval fmt cmd_name; Ok `Help
| `Exn (e, bt) ->
Cmdliner_msg.pp_backtrace err_ppf eval e bt; (Error `Exn)
| `Error (usage, err) ->
(if usage
then Cmdliner_msg.pp_usage_and_err err_ppf eval ~err
else Cmdliner_msg.pp_err err_ppf eval ~err);
Error `Term
let do_deprecated_msgs ~env err_ppf cl eval =
let cmd_info = Cmdliner_def.Eval.cmd eval in
let deprecated = Cmdliner_def.Cline.deprecated ~env cl in
match Cmdliner_def.Cmd_info.deprecated cmd_info, deprecated with
| None, [] -> ()
| depr_cmd, deprs ->
let open Cmdliner_base in
let pp_sep ppf () =
if Option.is_some depr_cmd && deprs <> [] then Fmt.cut ppf ();
in
let subst = Cmdliner_def.Eval.doclang_subst eval in
let pp_cmd_msg ppf cmd =
match
Cmdliner_def.Cmd_info.styled_deprecated ~subst ~errs:err_ppf cmd
with
| "" -> ()
| msg ->
let name = Cmdliner_def.Cmd_info.name cmd in
Fmt.pf ppf "@[%a command %a:@[ %a@]@]"
Fmt.deprecated () Fmt.code_or_quote name Fmt.styled_text msg
in
let pp_deprs = Fmt.list (Cmdliner_def.Cline.pp_deprecated ~subst) in
Fmt.pf err_ppf "@[%a @[<v>%a%a%a@]@]@."
Cmdliner_msg.pp_exec_msg eval pp_cmd_msg cmd_info
pp_sep () pp_deprs deprs
let find_cmd_and_parser ~legacy_prefixes ~for_completion args cmd =
(* This finds the command to use if it's a group and [for_completion]
is [true] whether we may need to add the subcommand names to the
completions. *)
let stop ~ancestors ~cmd args = match (cmd : 'a Cmdliner_cmd.t) with
| Cmd (_, parser) -> ancestors, cmd, args, Ok parser
| Group (_, (Some parser, _)) -> ancestors, cmd, args, Ok parser
| Group (_, (None, children)) ->
let dom = Cmdliner_cmd.list_names children in
let err = Cmdliner_msg.err_cmd_missing ~dom in
let try_stdopts = true in
ancestors, cmd, args, Error (`Parse (try_stdopts, err))
in
let rec loop ~ancestors ~current_cmd = function
| "--" :: _ | [] as args -> stop ~ancestors ~cmd:current_cmd args
| arg :: _ as args when for_completion &&
Cmdliner_cline.has_complete_prefix arg ->
begin match current_cmd with
| Cmd _ -> (* arg completion *) stop ~ancestors ~cmd:current_cmd args
| Group (_, (parser, _)) ->
let is_opt = Cmdliner_cline.(is_opt (get_token_to_complete arg)) in
if not is_opt then ancestors, current_cmd, args, Error `Complete else
stop ~ancestors ~cmd:current_cmd args
end
| arg :: _ as args when Cmdliner_cline.is_opt arg ->
stop ~ancestors ~cmd:current_cmd args
| arg :: rest as args ->
match current_cmd with
| Cmd (i, parser) -> ancestors, current_cmd, args, Ok parser
| Group (i, (_, children)) ->
let cmd_index = Cmdliner_cmd.name_trie children in
match Cmdliner_trie.find ~legacy_prefixes cmd_index arg with
| Ok cmd -> loop ~ancestors:(i :: ancestors) ~current_cmd:cmd rest
| Error `Not_found ->
let all = Cmdliner_trie.ambiguities cmd_index "" in
let hints = Cmdliner_base.suggest arg all in
let dom = Cmdliner_cmd.list_names children in
let kind = "command" in
let err = Cmdliner_base.err_unknown ~kind ~dom ~hints arg in
let try_stdopts =
(* When one writes [cmd no_such_cmd --help] it's better
to show the unknown command error message rather
than get into the help of the parent command. Otherwise
one gets confused into thinking the command exists and/or
annoyed not to be reading the right man page. *)
false
in
ancestors, current_cmd, args, Error (`Parse (try_stdopts, err))
| Error `Ambiguous (* Only on legacy prefixes *) ->
let ambs = Cmdliner_trie.ambiguities cmd_index arg in
let ambs = List.sort compare ambs in
let err = Cmdliner_base.err_ambiguous ~kind:"command" arg ~ambs in
let try_stdopts = false in
ancestors, current_cmd, args, Error (`Parse (try_stdopts, err))
in
loop ~ancestors:[] ~current_cmd:cmd args
let cli_args_of_argv argv = match Array.to_list argv with
| exec :: "--__complete" :: args -> true, args
| exec :: args -> false, args
| [] -> invalid_arg err_argv
let eval_value
?help:(help_ppf = Format.std_formatter)
?err:(err_ppf = Format.err_formatter)
?(catch = true) ?(env = Sys.getenv_opt) ?(argv = Sys.argv) cmd
=
let legacy_prefixes = Cmdliner_trie.legacy_prefixes ~env in
let for_completion, args = cli_args_of_argv argv in
let ancestors, cmd, args, parser =
find_cmd_and_parser ~legacy_prefixes ~for_completion args cmd
in
let help, version, eval =
let subcmds = Cmdliner_cmd.get_children_infos cmd in
let cmd = Cmdliner_cmd.get_info cmd in
let eval = Cmdliner_def.Eval.make ~ancestors ~cmd ~subcmds ~env ~err_ppf in
add_stdopts eval
in
let cline =
let args_info = Cmdliner_def.Cmd_info.args (Cmdliner_def.Eval.cmd eval) in
Cmdliner_cline.create ~legacy_prefixes ~for_completion args_info args
in
let res = match parser with
| Error (`Parse (try_stdopts, msg)) ->
(* Command lookup error, we may still prioritize stdargs *)
begin match cline with
| `Complete c -> Error (`Complete c)
| `Error (_, cl) | `Ok cl ->
let stdopts =
if try_stdopts
then try_eval_stdopts ~catch eval cl help version else None
in
begin match stdopts with
| None -> Error (`Error (true, msg))
| Some e -> e
end
end
| Error `Complete ->
begin match cline with
| `Complete (comp, cline) ->
let comp = Cmdliner_def.Complete.add_subcmds comp in
Error (`Complete (comp, cline))
| `Ok _ | `Error _ -> assert false
end
| Ok parser ->
begin match cline with
| `Complete c -> Error (`Complete c)
| `Error (e, cl) ->
begin match try_eval_stdopts ~catch eval cl help version with
| Some e -> e
| None -> Error (`Error (true, e))
end
| `Ok cl ->
match try_eval_stdopts ~catch eval cl help version with
| Some e -> e
| None ->
do_deprecated_msgs ~env err_ppf cl eval;
(run_parser ~catch eval cl parser :> 'a eval_result)
end
in
do_result ~env help_ppf err_ppf eval res
let eval_peek_opts
?(version_opt = false) ?(env = Sys.getenv_opt) ?(argv = Sys.argv) t
: 'a option * ('a eval_ok, eval_error) result
=
let legacy_prefixes = Cmdliner_trie.legacy_prefixes ~env in
let for_completion, args = cli_args_of_argv argv in
let version = if version_opt then Some "dummy" else None in
let cmd_info, parser =
let args, parser = Cmdliner_term.argset t, Cmdliner_term.parser t in
let cmd_info = Cmdliner_def.Cmd_info.make ?version "dummy" in
Cmdliner_def.Cmd_info.add_args cmd_info args, parser
in
let help, version, eval =
let err_ppf = Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()) in
let ancestors = [] and cmd = cmd_info and subcmds = [] in
let eval = Cmdliner_def.Eval.make ~ancestors ~cmd ~subcmds ~env ~err_ppf in
add_stdopts eval
in
let cline =
let arg_infos = Cmdliner_def.Cmd_info.args (Cmdliner_def.Eval.cmd eval) in
Cmdliner_cline.create
~peek_opts:true ~legacy_prefixes ~for_completion arg_infos args
in
let v, ret = match cline with
| `Complete comp -> None, (Error (`Complete comp))
| `Error (e, cl) ->
begin match try_eval_stdopts ~catch:true eval cl help version with
| Some e -> None, e
| None -> None, Error (`Error (true, e))
end
| `Ok cl ->
let ret = run_parser ~catch:true eval cl parser in
let v = match ret with Ok v -> Some v | Error _ -> None in
begin match try_eval_stdopts ~catch:true eval cl help version with
| Some e -> v, e
| None -> v, (ret :> 'a eval_result)
end
in
let ret = match ret with
| Ok v -> Ok (`Ok v)
| Error `Std_help _ -> Ok `Help
| Error `Std_version -> Ok `Version
| Error `Parse _ -> Error `Parse
| Error `Help _ -> Ok `Help
| Error `Complete _ -> Ok `Help
| Error `Exn _ -> Error `Exn
| Error `Error _ -> Error `Term
in
(v, ret)
let exit_status_of_result ?(term_err = Cmdliner_def.Exit.cli_error) = function
| Ok (`Ok _ | `Help | `Version) -> Cmdliner_def.Exit.ok
| Error `Term -> term_err
| Error `Parse -> Cmdliner_def.Exit.cli_error
| Error `Exn -> Cmdliner_def.Exit.internal_error
let eval_value' ?help ?err ?catch ?env ?argv ?term_err cmd =
match eval_value ?help ?err ?catch ?env ?argv cmd with
| Ok (`Ok _ as v) -> v
| ret -> `Exit (exit_status_of_result ?term_err ret)
let eval ?help ?err ?catch ?env ?argv ?term_err cmd =
exit_status_of_result ?term_err @@
eval_value ?help ?err ?catch ?env ?argv cmd
let eval' ?help ?err ?catch ?env ?argv ?term_err cmd =
match eval_value ?help ?err ?catch ?env ?argv cmd with
| Ok (`Ok c) -> c
| r -> exit_status_of_result ?term_err r
let pp_err ppf cmd ~msg =
(* Here instead of Cmdliner_msgs to avoid circular dep *)
let name = Cmdliner_cmd.name cmd in
Cmdliner_base.Fmt.pf ppf "%s: @[%a@]@." name Cmdliner_base.Fmt.lines msg
let eval_result
?help ?(err = Format.err_formatter) ?catch ?env ?argv ?term_err cmd
=
match eval_value ?help ~err ?catch ?env ?argv cmd with
| Ok (`Ok (Error msg)) -> pp_err err cmd ~msg; Cmdliner_def.Exit.some_error
| r -> exit_status_of_result ?term_err r
let eval_result'
?help ?(err = Format.err_formatter) ?catch ?env ?argv ?term_err cmd
=
match eval_value ?help ~err ?catch ?env ?argv cmd with
| Ok (`Ok (Ok c)) -> c
| Ok (`Ok (Error msg)) -> pp_err err cmd ~msg; Cmdliner_def.Exit.some_error
| r -> exit_status_of_result ?term_err r

48
unikernel/duniverse/cmdliner/src/cmdliner_eval.mli Normal file
View file

@ -0,0 +1,48 @@
(*---------------------------------------------------------------------------
Copyright (c) 2022 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(** Command evaluation *)
type 'a eval_ok = [ `Ok of 'a | `Version | `Help ]
type eval_error = [ `Parse | `Term | `Exn ]
type 'a eval_exit = [ `Ok of 'a | `Exit of Cmdliner_def.Exit.code ]
val eval_value :
?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool ->
?env:(string -> string option) -> ?argv:string array -> 'a Cmdliner_cmd.t ->
('a eval_ok, eval_error) result
val eval_value' :
?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool ->
?env:(string -> string option) -> ?argv:string array ->
?term_err:int -> 'a Cmdliner_cmd.t -> 'a eval_exit
val eval_peek_opts :
?version_opt:bool -> ?env:(string -> string option) ->
?argv:string array -> 'a Cmdliner_term.t ->
'a option * ('a eval_ok, eval_error) result
val eval :
?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool ->
?env:(string -> string option) -> ?argv:string array ->
?term_err:int -> unit Cmdliner_cmd.t -> Cmdliner_def.Exit.code
val eval' :
?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool ->
?env:(string -> string option) -> ?argv:string array ->
?term_err:int -> int Cmdliner_cmd.t -> Cmdliner_def.Exit.code
val eval_result :
?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool ->
?env:(string -> string option) -> ?argv:string array ->
?term_err:Cmdliner_def.Exit.code -> (unit, string) result Cmdliner_cmd.t ->
Cmdliner_def.Exit.code
val eval_result' :
?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool ->
?env:(string -> string option) -> ?argv:string array ->
?term_err:Cmdliner_def.Exit.code ->
(Cmdliner_def.Exit.code, string) result Cmdliner_cmd.t ->
Cmdliner_def.Exit.code

557
unikernel/duniverse/cmdliner/src/cmdliner_manpage.ml Normal file
View file

@ -0,0 +1,557 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(* Manpages *)
type section_name = string
type block =
[ `S of section_name | `P of string | `Pre of string | `I of string * string
| `Noblank | `Blocks of block list ]
type title = string * int * string * string * string
type t = title * block list
type xref =
[ `Main | `Cmd of string | `Tool of string | `Page of string * int ]
(* Standard sections *)
let s_name = "NAME"
let s_synopsis = "SYNOPSIS"
let s_description = "DESCRIPTION"
let s_commands = "COMMANDS"
let s_arguments = "ARGUMENTS"
let s_options = "OPTIONS"
let s_common_options = "COMMON OPTIONS"
let s_exit_status = "EXIT STATUS"
let s_exit_status_intro = `P "$(cmd) exits with:"
let s_environment = "ENVIRONMENT"
let s_environment_intro =
`P "These environment variables affect the execution of $(cmd):"
let s_files = "FILES"
let s_examples = "EXAMPLES"
let s_bugs = "BUGS"
let s_authors = "AUTHORS"
let s_see_also = "SEE ALSO"
let s_none = "cmdliner-none"
(* Section order *)
let s_created = ""
let order =
[| s_name; s_synopsis; s_description; s_created; s_commands;
s_arguments; s_options; s_common_options; s_exit_status;
s_environment; s_files; s_examples; s_bugs; s_authors; s_see_also;
s_none; |]
let order_synopsis = 1
let order_created = 3
let section_of_order i = order.(i)
let section_to_order ~on_unknown s =
let max = Array.length order - 1 in
let rec loop i = match i > max with
| true -> on_unknown
| false -> if order.(i) = s then i else loop (i + 1)
in
loop 0
(* Section maps
Section maps, maps section names to their section order and reversed
content blocks (content is not reversed in `Block blocks). The sections
are listed in reversed order. Unknown sections get the order of the last
known section. *)
type smap = (string * (int * block list)) list
let smap_of_blocks bs = (* N.B. this flattens `Blocks, not t.r. *)
let rec loop s s_o rbs smap = function
| [] -> s, s_o, rbs, smap
| `S new_sec :: bs ->
let new_o = section_to_order ~on_unknown:s_o new_sec in
loop new_sec new_o [] ((s, (s_o, rbs)):: smap) bs
| `Blocks blist :: bs ->
let s, s_o, rbs, rmap = loop s s_o rbs smap blist (* not t.r. *) in
loop s s_o rbs rmap bs
| (`P _ | `Pre _ | `I _ | `Noblank as c) :: bs ->
loop s s_o (c :: rbs) smap bs
in
let first, (bs : block list) = match bs with
| `S s :: bs -> s, bs
| `Blocks (`S s :: blist) :: bs -> s, (`Blocks blist) :: bs
| _ -> "", bs
in
let first_o = section_to_order ~on_unknown:order_synopsis first in
let s, s_o, rc, smap = loop first first_o [] [] bs in
(s, (s_o, rc)) :: smap
let smap_to_blocks smap = (* N.B. this leaves `Blocks content untouched. *)
let rec loop acc smap s = function
| b :: rbs -> loop (b :: acc) smap s rbs
| [] ->
let acc = if s = "" then acc else `S s :: acc in
match smap with
| [] -> acc
| (_, (_, [])) :: smap -> loop acc smap "" [] (* skip empty section *)
| (s, (_, rbs)) :: smap ->
if s = s_none
then loop acc smap "" [] (* skip *)
else loop acc smap s rbs
in
loop [] smap "" []
let smap_has_section smap ~sec = List.exists (fun (s, _) -> sec = s) smap
let smap_append_block smap ~sec b =
let o = section_to_order ~on_unknown:order_created sec in
let try_insert =
let rec loop max_lt_o left = function
| (s', (o, rbs)) :: right when s' = sec ->
Ok (List.rev_append ((sec, (o, b :: rbs)) :: left) right)
| (_, (o', _) as s) :: right ->
let max_lt_o = if o' < o then max o' max_lt_o else max_lt_o in
loop max_lt_o (s :: left) right
| [] ->
if max_lt_o <> -1 then Error max_lt_o else
Ok (List.rev ((sec, (o, [b])) :: left))
in
loop (-1) [] smap
in
match try_insert with
| Ok smap -> smap
| Error insert_before ->
let rec loop left = function
| (s', (o', _)) :: _ as right when o' = insert_before ->
List.rev_append ((sec, (o, [b])) :: left) right
| s :: ss -> loop (s :: left) ss
| [] -> assert false
in
loop [] smap
(* Formatting tools *)
let strf = Printf.sprintf
module Fmt = Cmdliner_base.Fmt
(* Cmdliner markup handling *)
let err e fmt = Fmt.pf e ("cmdliner error: " ^^ fmt ^^ "@.")
let err_unescaped ~errs c s = err errs "unescaped %C in %S" c s
let err_malformed ~errs s = err errs "Malformed $(…) in %S" s
let err_unclosed ~errs s = err errs "Unclosed $(…) in %S" s
let err_undef ~errs id s = err errs "Undefined variable $(%s) in %S" id s
let err_illegal_esc ~errs c s = err errs "Illegal escape char %C in %S" c s
let err_markup ~errs dir s =
err errs "Unknown cmdliner markup $(%c,…) in %S" dir s
let is_markup_dir = function 'i' | 'b' -> true | _ -> false
let is_markup_esc = function '$' | '\\' | '(' | ')' -> true | _ -> false
let markup_need_esc = function '\\' | '$' -> true | _ -> false
let markup_text_need_esc = function '\\' | '$' | ')' -> true | _ -> false
let escape s = (* escapes [s] from doc language. *)
let max_i = String.length s - 1 in
let rec escaped_len i l =
if i > max_i then l else
if markup_text_need_esc s.[i] then escaped_len (i + 1) (l + 2) else
escaped_len (i + 1) (l + 1)
in
let escaped_len = escaped_len 0 0 in
if escaped_len = String.length s then s else
let b = Bytes.create escaped_len in
let rec loop i k =
if i > max_i then Bytes.unsafe_to_string b else
let c = String.unsafe_get s i in
if not (markup_text_need_esc c)
then (Bytes.unsafe_set b k c; loop (i + 1) (k + 1))
else (Bytes.unsafe_set b k '\\'; Bytes.unsafe_set b (k + 1) c;
loop (i + 1) (k + 2))
in
loop 0 0
let subst_vars ~errs ~subst b s =
let max_i = String.length s - 1 in
let flush start stop = match start > max_i with
| true -> ()
| false -> Buffer.add_substring b s start (stop - start + 1)
in
let skip_escape k start i =
if i > max_i then err_unescaped ~errs '\\' s else k start (i + 1)
in
let rec skip_markup k start i =
if i > max_i then (err_unclosed ~errs s; k start i) else
match s.[i] with
| '\\' -> skip_escape (skip_markup k) start (i + 1)
| ')' -> k start (i + 1)
| c -> skip_markup k start (i + 1)
in
let rec add_subst start i =
if i > max_i then (err_unclosed ~errs s; loop start i) else
if s.[i] <> ')' then add_subst start (i + 1) else
let id = String.sub s start (i - start) in
let next = i + 1 in
begin match subst id with
| None -> err_undef ~errs id s; Buffer.add_string b "undefined";
| Some v -> Buffer.add_string b v
end;
loop next next
and loop start i =
if i > max_i then flush start max_i else
let next = i + 1 in
match s.[i] with
| '\\' -> skip_escape loop start next
| '$' ->
if next > max_i then err_unescaped ~errs '$' s else
begin match s.[next] with
| '(' ->
let min = next + 2 in
if min > max_i then (err_unclosed ~errs s; loop start next) else
begin match s.[min] with
| ',' -> skip_markup loop start (min + 1)
| _ ->
let start_id = next + 1 in
flush start (i - 1); add_subst start_id start_id
end
| _ -> err_unescaped ~errs '$' s; loop start next
end;
| c -> loop start next
in
(Buffer.clear b; loop 0 0; Buffer.contents b)
let add_markup_esc ~errs k b s start next target_need_escape target_escape =
let max_i = String.length s - 1 in
if next > max_i then err_unescaped ~errs '\\' s else
match s.[next] with
| c when not (is_markup_esc s.[next]) ->
err_illegal_esc ~errs c s;
k (next + 1) (next + 1)
| c ->
(if target_need_escape c then target_escape b c else Buffer.add_char b c);
k (next + 1) (next + 1)
let add_markup_text ~errs k b s start target_need_escape target_escape =
let max_i = String.length s - 1 in
let flush start stop = match start > max_i with
| true -> ()
| false -> Buffer.add_substring b s start (stop - start + 1)
in
let rec loop start i =
if i > max_i then (err_unclosed ~errs s; flush start max_i) else
let next = i + 1 in
match s.[i] with
| '\\' -> (* unescape *)
flush start (i - 1);
add_markup_esc ~errs loop b s start next
target_need_escape target_escape
| ')' -> flush start (i - 1); k next next
| c when markup_text_need_esc c ->
err_unescaped ~errs c s; flush start (i - 1); loop next next
| c when target_need_escape c ->
flush start (i - 1); target_escape b c; loop next next
| c -> loop start next
in
loop start start
(* Plain text output *)
let markup_to_plain ~styled ~errs b s =
let max_i = String.length s - 1 in
let flush start stop = match start > max_i with
| true -> ()
| false -> Buffer.add_substring b s start (stop - start + 1)
in
let need_escape _ = false in
let escape _ _ = assert false in
let rec end_text start i = Buffer.add_string b "\x1B[m"; loop start i
and loop start i =
if i > max_i then flush start max_i else
let next = i + 1 in
match s.[i] with
| '\\' ->
flush start (i - 1);
add_markup_esc ~errs loop b s start next need_escape escape
| '$' ->
if next > max_i then err_unescaped ~errs '$' s else
begin match s.[next] with
| '(' ->
let min = next + 2 in
if min > max_i then (err_unclosed ~errs s; loop start next) else
begin match s.[min] with
| ',' ->
let markup = s.[min - 1] in
let start_data = min + 1 in
if not (is_markup_dir markup)
then (err_markup ~errs markup s; loop start next) else begin
flush start (i - 1);
if not styled then
add_markup_text ~errs loop b s start_data need_escape escape
else
begin
begin match markup with
| 'i' -> Buffer.add_string b "\x1B[04m";
| 'b' -> Buffer.add_string b "\x1B[01m"
| _ -> assert false
end;
add_markup_text ~errs end_text b s start_data
need_escape escape
end
end
| _ ->
err_malformed ~errs s; loop start next
end
| _ -> err_unescaped ~errs '$' s; loop start next
end
| c when markup_need_esc c ->
err_unescaped ~errs c s; flush start (i - 1); loop next next
| c -> loop start next
in
(Buffer.clear b; loop 0 0; Buffer.contents b)
let doc_to_plain ~errs ~subst b s =
markup_to_plain ~styled:false ~errs b (subst_vars ~errs ~subst b s)
let doc_to_styled ?buffer:(b = Buffer.create 255) ~errs ~subst s =
let styled = Cmdliner_base.Fmt.styler () = Cmdliner_base.Fmt.Ansi in
markup_to_plain ~styled ~errs b (subst_vars ~errs ~subst b s)
let p_indent = 7 (* paragraph indentation. *)
let l_indent = 4 (* label indentation. *)
let pp_plain_blocks ~errs subst ppf ts =
let b = Buffer.create 1024 in
let markup t = doc_to_plain ~errs b ~subst t in
let pp_tokens ppf t = Fmt.tokens ~spaces:true ppf t in
let rec blank_line = function
| `Noblank :: ts -> loop ts
| ts -> Format.pp_print_cut ppf (); loop ts
and loop = function
| [] -> ()
| t :: ts ->
match t with
| `Noblank -> loop ts
| `Blocks bs -> loop (bs @ ts)
| `P s ->
Fmt.pf ppf "%a@[%a@]@," Fmt.indent p_indent pp_tokens (markup s);
blank_line ts
| `S s -> Fmt.pf ppf "@[%a@]@," pp_tokens (markup s); loop ts
| `Pre s ->
Fmt.pf ppf "%a@[%a@]@," Fmt.indent p_indent Fmt.lines (markup s);
blank_line ts
| `I (label, s) ->
let label = markup label and s = markup s in
Fmt.pf ppf "@[%a@[%a@]" Fmt.indent p_indent pp_tokens label;
begin match s with
| "" -> Fmt.pf ppf "@]@,"
| s ->
let ll = String.length label in
if ll < l_indent
then (Fmt.pf ppf "%a@[%a@]@]@,"
Fmt.indent (l_indent - ll) pp_tokens s)
else (Fmt.pf ppf "@\n%a@[%a@]@]@,"
Fmt.indent (p_indent + l_indent) pp_tokens s)
end;
blank_line ts
in
loop ts
let pp_plain_page ~errs subst ppf (_, text) =
Fmt.pf ppf "@[<v>%a@]" (pp_plain_blocks ~errs subst) text
(* Groff output *)
let markup_to_groff ~errs b s =
let max_i = String.length s - 1 in
let flush start stop = match start > max_i with
| true -> ()
| false -> Buffer.add_substring b s start (stop - start + 1)
in
let need_escape = function '.' | '\'' | '-' | '\\' -> true | _ -> false in
let escape b c = Printf.bprintf b "\\N'%d'" (Char.code c) in
let rec end_text start i = Buffer.add_string b "\\fR"; loop start i
and loop start i =
if i > max_i then flush start max_i else
let next = i + 1 in
match s.[i] with
| '\\' ->
flush start (i - 1);
add_markup_esc ~errs loop b s start next need_escape escape
| '$' ->
if next > max_i then err_unescaped ~errs '$' s else
begin match s.[next] with
| '(' ->
let min = next + 2 in
if min > max_i then (err_unclosed ~errs s; loop start next) else
begin match s.[min] with
| ',' ->
let start_data = min + 1 in
flush start (i - 1);
begin match s.[min - 1] with
| 'i' -> Buffer.add_string b "\\fI"
| 'b' -> Buffer.add_string b "\\fB"
| markup -> err_markup ~errs markup s
end;
add_markup_text ~errs end_text b s start_data need_escape escape
| _ -> err_malformed ~errs s; loop start next
end
| _ -> err_unescaped ~errs '$' s; flush start (i - 1); loop next next
end
| c when markup_need_esc c ->
err_unescaped ~errs c s; flush start (i - 1); loop next next
| c when need_escape c ->
flush start (i - 1); escape b c; loop next next
| c -> loop start next
in
(Buffer.clear b; loop 0 0; Buffer.contents b)
let doc_to_groff ~errs ~subst b s =
markup_to_groff ~errs b (subst_vars ~errs ~subst b s)
let pp_groff_blocks ~errs subst ppf text =
let buf = Buffer.create 1024 in
let markup t = doc_to_groff ~errs ~subst buf t in
let pp_tokens ppf t = Fmt.tokens ~spaces:false ppf t in
let rec pp_block = function
| `Blocks bs -> List.iter pp_block bs (* not T.R. *)
| `P s -> Fmt.pf ppf "@\n.P@\n%a" pp_tokens (markup s)
| `Pre s -> Fmt.pf ppf "@\n.P@\n.nf@\n%a@\n.fi" Fmt.lines (markup s)
| `S s -> Fmt.pf ppf "@\n.SH %a" pp_tokens (markup s)
| `Noblank -> Fmt.pf ppf "@\n.sp -1"
| `I (l, s) ->
Fmt.pf ppf "@\n.TP 4@\n%a@\n%a" pp_tokens (markup l) pp_tokens (markup s)
in
List.iter pp_block text
let pp_groff_page ~errs subst ppf ((n, s, a1, a2, a3), t) =
Fmt.pf ppf
".\\\" Pipe this output to groff -m man -K utf8 -T utf8 | less -R@\n\
.\\\"@\n\
.mso an.tmac@\n\
.TH \"%s\" %d \"%s\" \"%s\" \"%s\"@\n\
.\\\" Disable hyphenation and ragged-right@\n\
.nh@\n\
.ad l\
%a@?"
n s a1 a2 a3 (pp_groff_blocks ~errs subst) t
(* Printing to a pager *)
let pp_to_temp_file pp_v v =
try
let exec = Filename.basename Sys.argv.(0) in
let file, oc = Filename.open_temp_file exec "out" in
let ppf = Format.formatter_of_out_channel oc in
pp_v ppf v; Format.pp_print_flush ppf (); close_out oc;
at_exit (fun () -> try Sys.remove file with Sys_error e -> ());
Some file
with Sys_error _ -> None
let tmp_file_for_pager () =
try
let exec = Filename.basename Sys.argv.(0) in
let file = Filename.temp_file exec "tty" in
at_exit (fun () -> try Sys.remove file with Sys_error e -> ());
Some file
with Sys_error _ -> None
let find_cmd cmds =
let find_win32 (cmd, _args) =
(* `where` does not support full path lookups *)
if String.equal (Filename.basename cmd) cmd
then (Sys.command (strf "where %s 1> NUL 2> NUL" cmd) = 0)
else Sys.file_exists cmd
in
let find_posix (cmd, _args) =
Sys.command (strf "command -v %s 1>/dev/null 2>/dev/null" cmd) = 0
in
let find = if Sys.win32 then find_win32 else find_posix in
try Some (List.find find cmds) with Not_found -> None
let getenv_empty_is_none env var = match env var with
| None | Some "" -> None | Some _ as v -> v
let find_pager env =
let cmds = ["less", ""; "more", ""] in
let cmds = match getenv_empty_is_none env "PAGER" with
| Some pager -> (pager, "") :: cmds | None -> cmds
in
let cmds = match getenv_empty_is_none env "MANPAGER" with
| Some manpager -> (manpager, "") :: cmds | None -> cmds
in
find_cmd cmds
let pp_to_pager env print ppf v = match find_pager env with
| None -> print `Plain ppf v
| Some (pager, opts) ->
let pager =
let set_less_env = match env "LESS" with
| None -> if Sys.win32 then "set LESS=FRX && " else "LESS=FRX "
| Some _ -> "" (* Sys.command will pass it *)
in
set_less_env ^ pager ^ opts
in
let groffer =
let cmds =
["mandoc", " -m man -K utf-8 -T utf8";
"groff", " -m man -K utf8 -T utf8";
"nroff", ""]
in
find_cmd cmds
in
let cmd = match groffer with
| None ->
begin match pp_to_temp_file (print `Plain) v with
| None -> None
| Some f -> Some (strf "%s < %s" pager f)
end
| Some (groffer, opts) ->
let groffer = groffer ^ opts in
begin match pp_to_temp_file (print `Groff) v with
| None -> None
| Some f when Sys.win32 ->
(* For some obscure reason the pipe below does not
work. We need to use a temporary file.
https://github.com/dbuenzli/cmdliner/issues/166 *)
begin match tmp_file_for_pager () with
| None -> None
| Some tmp ->
Some (strf "%s <%s >%s && %s <%s" groffer f tmp pager tmp)
end
| Some f ->
Some (strf "%s < %s | %s" groffer f pager)
end
in
match cmd with
| None -> print `Plain ppf v
| Some cmd -> if (Sys.command cmd) <> 0 then print `Plain ppf v
(* Output *)
type subst = string -> string option
type format = [ `Auto | `Pager | `Plain | `Groff ]
let rec print
?(env = Sys.getenv_opt) ?(errs = Format.err_formatter)
?(subst = fun x -> None) fmt ppf page
=
match fmt with
| `Pager -> pp_to_pager env (print ~env ~errs ~subst) ppf page
| `Plain -> pp_plain_page ~errs subst ppf page
| `Groff -> pp_groff_page ~errs subst ppf page
| `Auto ->
let fmt =
match env "TERM" with
| None when Sys.win32 -> `Pager
| None -> `Plain
| Some "dumb" -> `Plain
| _ -> `Pager
in
print ~env ~errs ~subst fmt ppf page

92
unikernel/duniverse/cmdliner/src/cmdliner_manpage.mli Normal file
View file

@ -0,0 +1,92 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(** Manpages.
See {!Cmdliner.Manpage}. *)
type section_name = string
type block =
[ `S of section_name | `P of string | `Pre of string | `I of string * string
| `Noblank | `Blocks of block list ]
val escape : string -> string
(** [escape s] escapes [s] from the doc language. *)
type title = string * int * string * string * string
type t = title * block list
type xref =
[ `Main | `Cmd of string | `Tool of string | `Page of string * int ]
(** {1 Standard section names} *)
val s_name : section_name
val s_synopsis : section_name
val s_description : section_name
val s_commands : section_name
val s_arguments : section_name
val s_options : section_name
val s_common_options : section_name
val s_exit_status : section_name
val s_environment : section_name
val s_files : section_name
val s_bugs : section_name
val s_examples : section_name
val s_authors : section_name
val s_see_also : section_name
val s_none : section_name
(** {1 Section maps}
Used for handling the merging of metadata doc strings. *)
type smap
val smap_of_blocks : block list -> smap
val smap_to_blocks : smap -> block list
val smap_has_section : smap -> sec:section_name -> bool
val smap_append_block : smap -> sec:section_name -> block -> smap
(** [smap_append_block smap sec b] appends [b] at the end of section
[sec] creating it at the right place if needed. *)
(** {1 Content boilerplate} *)
val s_exit_status_intro : block
val s_environment_intro : block
(** {1 Output} *)
type subst = string -> string option
(** The type for variable substitution functions. *)
type format = [ `Auto | `Pager | `Plain | `Groff ]
val print :
?env:(string -> string option) ->
?errs:Format.formatter -> ?subst:subst -> format ->
Format.formatter -> t -> unit
(** {1 Printers and escapes used by Cmdliner module} *)
val subst_vars :
errs:Format.formatter -> subst:subst -> Buffer.t -> string -> string
(** [subst b ~subst s], using [b], substitutes in [s] variables of the form
"$(doc)" by their [subst] definition. This leaves escapes and markup
directives $(markup,…) intact.
@raise Invalid_argument in case of illegal syntax. *)
val doc_to_plain :
errs:Format.formatter -> subst:subst -> Buffer.t -> string -> string
(** [doc_to_plain b ~subst s] using [b], substitutes in [s] variables by
their [subst] definition and renders cmdliner directives to plain
text.
Raises Invalid_argument in case of illegal syntax. *)
val doc_to_styled :
?buffer:Buffer.t -> errs:Format.formatter -> subst:subst -> string -> string
(** [doc_to_styled] is like {!doc_to_plain} but uses ANSI escapes. *)

106
unikernel/duniverse/cmdliner/src/cmdliner_msg.ml Normal file
View file

@ -0,0 +1,106 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
module Fmt = Cmdliner_base.Fmt
(* Environment variable errors *)
let err_env_parse env ~err =
let var = Cmdliner_def.Env.info_var env in
Fmt.str "@[environment variable %a: %s@]" Fmt.code_or_quote var err
(* Positional argument errors *)
let err_pos_excess excess =
Fmt.str "@[%a, don't know what to do with %a@]"
Fmt.ereason "too many arguments"
Fmt.(list ~sep:comma code_or_quote) excess
let err_pos_miss a = match Cmdliner_def.Arg_info.docv a with
| "" -> Fmt.str "@[a required argument is %a@]" Fmt.missing ()
| v -> Fmt.str "@[required argument %a is %a@]" Fmt.code_var v Fmt.missing ()
let err_pos_misses = function
| [] -> assert false
| [a] -> err_pos_miss a
| args ->
let add_arg acc a = match Cmdliner_def.Arg_info.docv a with
| "" -> "ARG" :: acc
| argv -> argv :: acc
in
let rev_args = List.sort Cmdliner_def.Arg_info.rev_pos_cli_order args in
let args = List.fold_left add_arg [] rev_args in
Fmt.str "@[required arguments %a@ are@ %a@]"
Fmt.(list ~sep:comma code_var) args Fmt.missing ()
let err_pos_parse a ~err = match Cmdliner_def.Arg_info.docv a with
| "" -> err
| argv ->
match Cmdliner_def.Arg_info.(pos_len @@ pos_kind a) with
| Some 1 -> Fmt.str "@[%a argument: %s@]" Fmt.code_var argv err
| None | Some _ -> Fmt.str "@[%a… arguments: %s@]" Fmt.code_var argv err
(* Optional argument errors *)
let err_flag_value flag v =
Fmt.str "@[option %a is a flag, it@ %a@ %a@]"
Fmt.code_or_quote flag Fmt.ereason "cannot take the argument"
Fmt.code_or_quote v
let err_opt_value_missing f =
Fmt.str "@[option %a %a@]" Fmt.code_or_quote f Fmt.ereason "needs an argument"
let err_opt_parse f ~err =
Fmt.str "@[option %a: %a@]" Fmt.code_or_quote f Fmt.styled_text err
let err_opt_repeated f f' =
if f = f' then
Fmt.str "@[option %a %a@]"
Fmt.code_or_quote f Fmt.ereason "cannot be repeated"
else
Fmt.str "@[options %a and %a@ %a@]"
Fmt.code_or_quote f Fmt.code_or_quote f'
Fmt.ereason "cannot be present at the same time"
(* Argument errors *)
let err_arg_missing a =
if Cmdliner_def.Arg_info.is_pos a then err_pos_miss a else
Fmt.str "@[required option %a is %a@]"
Fmt.code (Cmdliner_def.Arg_info.opt_name_sample a) Fmt.missing ()
let err_cmd_missing ~dom =
Fmt.str "@[required %a name is %a,@ must@ be@ %a@]"
Fmt.code_var "COMMAND" Fmt.missing () Cmdliner_base.pp_alts dom
(* Other messages *)
let pp_version ppf ei =
match Cmdliner_def.Cmd_info.version (Cmdliner_def.Eval.main ei) with
| None -> assert false
| Some v -> Fmt.pf ppf "@[%s@]@." v
let exec_name ei = Cmdliner_def.Cmd_info.name (Cmdliner_def.Eval.main ei)
let pp_exec_msg ppf ei = Fmt.pf ppf "%s:" (exec_name ei)
let pp_err ppf ei ~err =
Fmt.pf ppf "@[%a @[%a@]@]@." pp_exec_msg ei Fmt.styled_text err
let pp_usage_and_err ppf ei ~err =
Fmt.pf ppf "@[Usage: @[%a@]@]@."
Fmt.styled_text (Cmdliner_docgen.styled_usage_synopsis ~errs:ppf ei);
pp_err ppf ei ~err
let pp_backtrace ppf ei e bt =
let bt = Printexc.raw_backtrace_to_string bt in
let bt =
let len = String.length bt in
if len > 0 then String.sub bt 0 (len - 1) (* remove final '\n' *) else bt
in
Fmt.pf ppf "@[%a @[internal error, %a:@\n%a@]@]@."
pp_exec_msg ei
Fmt.ereason "uncaught exception"
Fmt.lines (String.concat "\n" [Printexc.to_string e; bt])

45
unikernel/duniverse/cmdliner/src/cmdliner_msg.mli Normal file
View file

@ -0,0 +1,45 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(** Messages for the end-user. *)
(** {1:env_err Environment variable errors} *)
val err_env_parse : Cmdliner_def.Env.info -> err:string -> string
(** {1:pos_err Positional argument errors} *)
val err_pos_excess : string list -> string
val err_pos_misses : Cmdliner_def.Arg_info.t list -> string
val err_pos_parse : Cmdliner_def.Arg_info.t -> err:string -> string
(** {1:opt_err Optional argument errors} *)
val err_flag_value : string -> string -> string
val err_opt_value_missing : string -> string
val err_opt_parse : string -> err:string -> string
val err_opt_repeated : string -> string -> string
(** {1:arg_err Argument errors} *)
val err_arg_missing : Cmdliner_def.Arg_info.t -> string
val err_cmd_missing : dom:string list -> string
(** {1:msgs Other messages} *)
val pp_version : Cmdliner_def.Eval.t Cmdliner_base.Fmt.t
val pp_exec_msg : Cmdliner_def.Eval.t Cmdliner_base.Fmt.t
val pp_err :
Format.formatter -> Cmdliner_def.Eval.t -> err:string -> unit
val pp_usage_and_err :
Format.formatter -> Cmdliner_def.Eval.t -> err:string -> unit
val pp_backtrace :
Format.formatter -> Cmdliner_def.Eval.t -> exn -> Printexc.raw_backtrace ->
unit

97
unikernel/duniverse/cmdliner/src/cmdliner_term.ml Normal file
View file

@ -0,0 +1,97 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
type term_escape = Cmdliner_def.Term.escape
type 'a parser = 'a Cmdliner_def.Term.parser
type +'a t = 'a Cmdliner_def.Term.t
let make args p = (args, p)
let argset (args, _) = args
let parser (_, parser) = parser
let const v = Cmdliner_def.Arg_info.Set.empty, (fun _ _ -> Ok v)
let app (args_f, f) (args_v, v) =
Cmdliner_def.Arg_info.Set.union args_f args_v,
fun ei cl -> match (f ei cl) with
| Error _ as e -> e
| Ok f ->
match v ei cl with
| Error _ as e -> e
| Ok v -> Ok (f v)
let map f v = app (const f) v
let product v0 v1 = app (app (const (fun x y -> (x, y))) v0) v1
module Syntax = struct
let ( let+ ) v f = map f v
let ( and+ ) = product
end
(* Terms *)
let ( $ ) = app
type 'a ret = [ `Ok of 'a | term_escape ]
let ret (al, v) =
al, fun ei cl -> match v ei cl with
| Ok (`Ok v) -> Ok v
| Ok (`Error _ as err) -> Error err
| Ok (`Help _ as help) -> Error help
| Error _ as e -> e
let term_result ?(usage = false) (al, v) =
al, fun ei cl -> match v ei cl with
| Ok (Ok _ as ok) -> ok
| Ok (Error (`Msg e)) -> Error (`Error (usage, e))
| Error _ as e -> e
let term_result' ?usage t =
let wrap = app (const (Result.map_error (fun e -> `Msg e))) t in
term_result ?usage wrap
let cli_parse_result (al, v) =
al, fun ei cl -> match v ei cl with
| Ok (Ok _ as ok) -> ok
| Ok (Error (`Msg e)) -> Error (`Parse e)
| Error _ as e -> e
let cli_parse_result' t =
let wrap = app (const (Result.map_error (fun e -> `Msg e))) t in
cli_parse_result wrap
let main_name =
Cmdliner_def.Arg_info.Set.empty,
(fun ei _ -> Ok (Cmdliner_def.Cmd_info.name @@ Cmdliner_def.Eval.main ei))
let choice_names =
Cmdliner_def.Arg_info.Set.empty,
(fun ei _ ->
(* N.B. this keeps everything backward compatible. We return the command
names of main's children *)
let name t = Cmdliner_def.Cmd_info.name t in
let choices =
Cmdliner_def.Cmd_info.children (Cmdliner_def.Eval.main ei)
in
Ok (List.rev_map name choices))
let with_used_args (al, v) : (_ * string list) t =
al, fun ei cl ->
match v ei cl with
| Ok x ->
let actual_args arg_info _ acc =
let args = Cmdliner_def.Cline.actual_args cl arg_info in
List.rev_append args acc
in
let used =
List.rev (Cmdliner_def.Arg_info.Set.fold actual_args al [])
in
Ok (x, used)
| Error _ as e -> e
let env =
Cmdliner_def.Arg_info.Set.empty,
(fun ei _ -> Ok (Cmdliner_def.Eval.env_var ei))

48
unikernel/duniverse/cmdliner/src/cmdliner_term.mli Normal file
View file

@ -0,0 +1,48 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(** Terms *)
type term_escape =
[ `Error of bool * string
| `Help of Cmdliner_manpage.format * string option ]
type 'a parser =
Cmdliner_def.Eval.t -> Cmdliner_def.Cline.t ->
('a, [ `Parse of string | term_escape ]) result
(** Type type for command line parser. given static information about
the command line and a command line to parse returns an OCaml value. *)
type +'a t = 'a Cmdliner_def.Term.t
(** The type for terms. The list of arguments it can parse and the parsing
function that does so. *)
val make : Cmdliner_def.Arg_info.Set.t -> 'a parser -> 'a t
val argset : 'a t -> Cmdliner_def.Arg_info.Set.t
val parser : 'a t -> 'a parser
val const : 'a -> 'a t
val app : ('a -> 'b) t -> 'a t -> 'b t
val map : ('a -> 'b) -> 'a t -> 'b t
val product : 'a t -> 'b t -> ('a * 'b) t
module Syntax : sig
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t
end
val ( $ ) : ('a -> 'b) t -> 'a t -> 'b t
type 'a ret = [ `Ok of 'a | term_escape ]
val ret : 'a ret t -> 'a t
val term_result : ?usage:bool -> ('a, [`Msg of string]) result t -> 'a t
val term_result' : ?usage:bool -> ('a, string) result t -> 'a t
val cli_parse_result : ('a, [`Msg of string]) result t -> 'a t
val cli_parse_result' : ('a, string) result t -> 'a t
val main_name : string t
val choice_names : string list t
val with_used_args : 'a t -> ('a * string list) t
val env : (string -> string option) t

91
unikernel/duniverse/cmdliner/src/cmdliner_trie.ml Normal file
View file

@ -0,0 +1,91 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
module Cmap = Map.Make (Char) (* character maps. *)
type 'a value = (* type for holding a bound value. *)
| Pre of 'a (* value is bound by the prefix of a key. *)
| Key of 'a (* value is bound by an entire key. *)
| Amb (* no value bound because of ambiguous prefix. *)
| Nil (* not bound (only for the empty trie). *)
type 'a t = { v : 'a value; succs : 'a t Cmap.t }
let empty = { v = Nil; succs = Cmap.empty }
let is_empty t = t = empty
(* N.B. If we replace a non-ambiguous key, it becomes ambiguous but it's
not important for our use. Also the following is not tail recursive but
the stack is bounded by key length. *)
let add t k d =
let rec loop t k len i d pre_d = match i = len with
| true ->
let t' = { v = Key d; succs = t.succs } in
begin match t.v with
| Key old -> `Replaced (old, t')
| _ -> `New t'
end
| false ->
let v = match t.v with
| Amb | Pre _ -> Amb | Key _ as v -> v | Nil -> pre_d
in
let t' = try Cmap.find k.[i] t.succs with Not_found -> empty in
match loop t' k len (i + 1) d pre_d with
| `New n -> `New { v; succs = Cmap.add k.[i] n t.succs }
| `Replaced (o, n) ->
`Replaced (o, { v; succs = Cmap.add k.[i] n t.succs })
in
loop t k (String.length k) 0 d (Pre d (* allocate less *))
let find_node t k =
let rec aux t k len i =
if i = len then t else
aux (Cmap.find k.[i] t.succs) k len (i + 1)
in
aux t k (String.length k) 0
let find ~legacy_prefixes t k = match (find_node t k).v with
| Key v -> Ok v
| Pre v when legacy_prefixes -> Ok v
| Pre v -> Error `Not_found
| Amb when legacy_prefixes -> Error `Ambiguous
| Amb -> Error `Not_found
| Nil -> Error `Not_found
| exception Not_found -> Error `Not_found
let ambiguities t p = (* ambiguities of [p] in [t]. *)
try
let t = find_node t p in
match t.v with
| Key _ | Pre _ | Nil -> []
| Amb ->
let add_char s c = s ^ (String.make 1 c) in
let rem_char s = String.sub s 0 ((String.length s) - 1) in
let to_list m = Cmap.fold (fun k t acc -> (k,t) :: acc) m [] in
let rec aux acc p = function
| ((c, t) :: succs) :: rest ->
let p' = add_char p c in
let acc' = match t.v with
| Pre _ | Amb -> acc
| Key _ -> (p' :: acc)
| Nil -> assert false
in
aux acc' p' ((to_list t.succs) :: succs :: rest)
| [] :: [] -> acc
| [] :: rest -> aux acc (rem_char p) rest
| [] -> assert false
in
aux [] p (to_list t.succs :: [])
with Not_found -> []
let of_list l =
let add t (s, v) = match add t s v with `New t -> t | `Replaced (_, t) -> t in
List.fold_left add empty l
let legacy_prefixes ~env = match env "CMDLINER_LEGACY_PREFIXES" with
| None -> false
| Some s ->
match String.lowercase_ascii s with
| "true" | "yes" | "y" | "1" -> true
| _ -> false

22
unikernel/duniverse/cmdliner/src/cmdliner_trie.mli Normal file
View file

@ -0,0 +1,22 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
(** Tries.
This implementation also maps any non ambiguous prefix of a
key to its value. *)
type 'a t
val empty : 'a t
val is_empty : 'a t -> bool
val add : 'a t -> string -> 'a -> [ `New of 'a t | `Replaced of 'a * 'a t ]
val find :
legacy_prefixes:bool -> 'a t -> string ->
('a, [`Ambiguous | `Not_found ]) result
val ambiguities : 'a t -> string -> string list
val of_list : (string * 'a) list -> 'a t
val legacy_prefixes : env:(string -> string option) -> bool

3
unikernel/duniverse/cmdliner/src/dune Normal file
View file

@ -0,0 +1,3 @@
(library
(public_name cmdliner)
(wrapped false))

66
unikernel/duniverse/cmdliner/src/tool/bash-completion.sh Normal file
View file

@ -0,0 +1,66 @@
_cmdliner_generic() {
local prefix="${COMP_WORDS[COMP_CWORD]}"
local w=("${COMP_WORDS[@]}") # Keep COMP_WORDS intact for restart completion
w[COMP_CWORD]="--__complete=${COMP_WORDS[COMP_CWORD]}"
local line="${w[@]:0:1} --__complete ${w[@]:1}"
local version type group item text_line item_doc msg
{
read version
if [[ $version != "1" ]]; then
printf "\nUnsupported cmdliner completion protocol: $version" >&2
return 1
fi
while read type; do
if [[ $type == "group" ]]; then
read group
elif [[ $type == "dirs" ]] && (type compopt &> /dev/null); then
if [[ $prefix != -* ]]; then
COMPREPLY+=( $(compgen -d "$prefix") )
fi
elif [[ $type == "files" ]] && (type compopt &> /dev/null); then
if [[ $prefix != -* ]]; then
COMPREPLY+=( $(compgen -f "$prefix") )
fi
elif [[ $type == "message" ]]; then
msg="";
while read text_line; do
if [[ "$text_line" == "message-end" ]]; then
msg=${msg#?} # remove first newline
break
fi
msg+=$'\n'"$text_line"
done
printf "$msg" >&2
elif [[ $type == "item" ]]; then
read item;
item_doc="";
while read text_line; do
if [[ "$text_line" == "item-end" ]]; then
item_doc=${item_doc#?} # remove first newline
break
fi
item_doc+=$'\n'"$text_line"
done
# Sadly it seems bash does not support doc strings, so we only
# add item to to the reply. If you know any better get in touch.
# Handle glued forms, the completion item is the full option
if [[ $group == "Values" ]]; then
if [[ $prefix == --* ]]; then
item="${prefix%%=*}=$item"
elif [[ $prefix == -* ]]; then
item="${prefix:0:2}$item"
fi
fi
COMPREPLY+=($item)
elif [[ $type == "restart" ]]; then
# N.B. only emitted if there is a -- token
for ((i = 0; i < ${#COMP_WORDS[@]}; i++)); do
if [[ "${COMP_WORDS[i]}" == "--" ]]; then
_comp_command_offset $((i+1))
return
fi
done
fi
done } < <(eval $line)
return 0
}

143
unikernel/duniverse/cmdliner/src/tool/cmdliner_data.ml Normal file
View file

@ -0,0 +1,143 @@
let bash_generic_completion =
{|_cmdliner_generic() {
local prefix="${COMP_WORDS[COMP_CWORD]}"
local w=("${COMP_WORDS[@]}") # Keep COMP_WORDS intact for restart completion
w[COMP_CWORD]="--__complete=${COMP_WORDS[COMP_CWORD]}"
local line="${w[@]:0:1} --__complete ${w[@]:1}"
local version type group item text_line item_doc msg
{
read version
if [[ $version != "1" ]]; then
printf "\nUnsupported cmdliner completion protocol: $version" >&2
return 1
fi
while read type; do
if [[ $type == "group" ]]; then
read group
elif [[ $type == "dirs" ]] && (type compopt &> /dev/null); then
if [[ $prefix != -* ]]; then
COMPREPLY+=( $(compgen -d "$prefix") )
fi
elif [[ $type == "files" ]] && (type compopt &> /dev/null); then
if [[ $prefix != -* ]]; then
COMPREPLY+=( $(compgen -f "$prefix") )
fi
elif [[ $type == "message" ]]; then
msg="";
while read text_line; do
if [[ "$text_line" == "message-end" ]]; then
msg=${msg#?} # remove first newline
break
fi
msg+=$'\n'"$text_line"
done
printf "$msg" >&2
elif [[ $type == "item" ]]; then
read item;
item_doc="";
while read text_line; do
if [[ "$text_line" == "item-end" ]]; then
item_doc=${item_doc#?} # remove first newline
break
fi
item_doc+=$'\n'"$text_line"
done
# Sadly it seems bash does not support doc strings, so we only
# add item to to the reply. If you know any better get in touch.
# Handle glued forms, the completion item is the full option
if [[ $group == "Values" ]]; then
if [[ $prefix == --* ]]; then
item="${prefix%%=*}=$item"
elif [[ $prefix == -* ]]; then
item="${prefix:0:2}$item"
fi
fi
COMPREPLY+=($item)
elif [[ $type == "restart" ]]; then
# N.B. only emitted if there is a -- token
for ((i = 0; i < ${#COMP_WORDS[@]}; i++)); do
if [[ "${COMP_WORDS[i]}" == "--" ]]; then
_comp_command_offset $((i+1))
return
fi
done
fi
done } < <(eval $line)
return 0
}
|}
let zsh_generic_completion =
{|function _cmdliner_generic {
local w=("${words[@]}") # Keep words intact for restart completion
local prefix="${words[CURRENT]}"
w[CURRENT]="--__complete=${words[CURRENT]}"
local line="${w[@]:0:1} --__complete ${w[@]:1}"
local -a completions
local version type group item text_line item_doc msg
eval $line | {
read -r version
if [[ $version != "1" ]]; then
_message -r "Unsupported cmdliner completion protocol: $version"
return 1
fi
while IFS= read -r type; do
if [[ "$type" == "group" ]]; then
if [ -n "$completions" ]; then
_describe -V unsorted completions -U
completions=()
fi
read -r group
elif [[ "$type" == "message" ]]; then
msg="";
while read text_line; do
if [[ "$text_line" == "message-end" ]]; then
msg=${msg#?} # remove first newline
break
fi
msg+=$'\n'"$text_line"
done
_message -r "$msg"
elif [[ "$type" == "item" ]]; then
read -r item;
item_doc="";
while read -r text_line; do
if [[ "$text_line" == "item-end" ]]; then
item_doc=${item_doc#?} # remove first space
break
fi
# Sadly it seems impossible to make multiline
# doc strings. Get in touch if you know any better.
item_doc+=" $text_line"
done
# Handle glued forms, the completion item is the full option
if [[ "$group" == "Values" ]]; then
if [[ "$prefix" == --* ]]; then
item="${prefix%%=*}=${item}"
elif [[ "$prefix" == -* ]]; then
item="${prefix:0:2}${item}"
fi
fi
# item_doc="${item_doc//$'\e'\[(01m|04m|m)/}"
completions+=("${item}":"${item_doc}")
elif [[ "$type" == "dirs" ]]; then
_path_files -/
elif [[ "$type" == "files" ]]; then
_path_files -f
elif [[ "$type" == "restart" ]]; then
# N.B. only emitted if there is a -- token
while [[ $words[1] != "--" ]]; do
shift words
(( CURRENT-- ))
done
shift words
(( CURRENT-- ))
_normal
fi
done
}
if [ -n "$completions" ]; then
_describe -V unsorted completions -U
fi
}
|}

638
unikernel/duniverse/cmdliner/src/tool/cmdliner_main.ml Normal file
View file

@ -0,0 +1,638 @@
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
let strf = Printf.sprintf
let error_to_failure = function Ok v -> v | Error e -> failwith e
let find_sub ?(start = 0) ~sub s =
(* naive algorithm, worst case O(length sub * length s) *)
let len_sub = String.length sub in
let len_s = String.length s in
let max_idx_sub = len_sub - 1 in
let max_idx_s = if len_sub <> 0 then len_s - len_sub else len_s - 1 in
let rec loop i k =
if i > max_idx_s then None else
if k > max_idx_sub then Some i else
if k > 0 then
if String.get sub k = String.get s (i + k)
then loop i (k + 1) else loop (i + 1) 0
else
if String.get sub 0 = String.get s i
then loop i 1 else loop (i + 1) 0
in
loop start 0
let rec mkdir dir = (* Can be replaced by Sys.mkdir once we drop OCaml < 4.12 *)
(* On Windows -p does not exist we do it ourselves on all platforms. *)
let err_cmd exit cmd =
raise (Sys_error (strf "exited with %d: %s\n" exit cmd))
in
let run_cmd args =
let cmd = String.concat " " (List.map Filename.quote args) in
let cmd = if Sys.win32 then strf {|"%s"|} cmd else cmd in
let exit = Sys.command cmd in
if exit = 0 then () else err_cmd exit cmd
in
let parent = Filename.dirname dir in
(if String.equal dir parent then () else mkdir (Filename.dirname dir));
(if Sys.file_exists dir then () else run_cmd ["mkdir"; dir])
let read_file file =
(* In_channel is < 4.14 *)
let read file ic =
try
(* This fails on `stdin` or large files on 32-bit. Once we require
4.14 In_channel.input_all handles these quirks. *)
let len = in_channel_length ic in
let buf = Bytes.create len in
really_input ic buf 0 len; close_in ic;
Ok (Bytes.unsafe_to_string buf)
with
| Sys_error e -> Error (Printf.sprintf "%s: %s" file e)
in
let binary_stdin () = set_binary_mode_in stdin true in
try match file with
| "-" -> binary_stdin (); read file stdin
| file ->
let ic = open_in_bin file in
let finally () = close_in_noerr ic in
Fun.protect ~finally @@ fun () -> read file ic
with Sys_error e -> Error e
let write_file file s =
(* Out_channel is < 4.14 *)
let write file s oc = try Ok (output_string oc s) with
| Sys_error e -> Error (Printf.sprintf "%s: %s" file e)
in
let binary_stdout () = set_binary_mode_out stdout true in
try match file with
| "-" -> binary_stdout (); write file s stdout
| file ->
let oc = open_out_bin file in
let finally () = close_out_noerr oc in
Fun.protect ~finally @@ fun () -> write file s oc
with Sys_error e -> Error e
let with_binary_stdout f =
try let () = set_binary_mode_out stdout true in f () with
| Sys_error e | Failure e -> prerr_endline e; Cmdliner.Cmd.Exit.some_error
let exec_stdout tool ~args =
(* The cmd munging logic can be replaced by Filename.quote_command once we
drop OCaml < 4.10 *)
let quote_tool tool =
Filename.quote @@
if Sys.win32 then String.map (function '/' -> '\\' | c -> c) tool else tool
in
try
let tmp = Filename.temp_file "cmd" "stdout" in
let tool = quote_tool tool and args = List.map Filename.quote args in
let cmd = String.concat " " (tool :: args) in
let exec = String.concat " > " [cmd; Filename.quote tmp] in
let exec = if Sys.win32 then strf {|"%s"|} exec else exec in
match Sys.command exec with
| 0 ->
let ic = open_in_bin tmp in
let finally () =
close_in_noerr ic;
try Sys.remove tmp with Sys_error _ -> () (* not that important *)
in
let len = in_channel_length ic in
Fun.protect ~finally @@ fun () ->
let stdout = really_input_string ic len in
Ok stdout
| exit -> Error (strf "%s: exited with %d" exec exit)
with
| Sys_error e -> Error e
(* Opam .install file updating *)
let update_opam_install_section ~opam_src ~section moves =
(* Can fail in all sorts of ways if the '$(section):' string appears
in the file moves of [opam_src] *)
let move_to_string (src, dst) = Printf.sprintf " %S {%S}" src dst in
let open_section ~section opam_src =
let section = section ^ ":" in
match find_sub ~sub:section opam_src with
| None -> (strf "%s\n%s [" opam_src section), " ]"
| Some start ->
match String.index_from_opt opam_src start '[' with
| None ->
failwith (strf "Could not open section %s in opam file" section)
| Some i ->
let j = i + 1 in
String.sub opam_src 0 j,
String.sub opam_src j (String.length opam_src - j)
in
let before, after = open_section ~section opam_src in
let moves = List.rev_map move_to_string moves in
let moves = String.concat "\n" ("" :: moves) in
String.concat "" [before; moves; after]
let maybe_update_opam_install_file ~update_opam_install section moves =
match update_opam_install with
| None -> ()
| Some "-" -> failwith "- is stdin, it cannot be updated"
| Some file ->
let opam_src =
if not (Sys.file_exists file) then "" else
read_file file |> error_to_failure
in
let src = update_opam_install_section ~opam_src ~section moves in
write_file file src |> error_to_failure
(* Cmdliner based tool introspection.
Note this is a bit hackish but does the job. At some point we could
investigate cleaner protocols with the `--cmdliner` reserved option. *)
let split_toolname toolexec =
let tool, name = Scanf.sscanf toolexec "%s@:%s" (fun n e -> n, e) in
let name =
if name <> "" then name else
let name = Filename.basename tool in
match Filename.chop_suffix_opt ~suffix:".exe" tool with
| None -> name | Some name -> name
in
tool, name
let get_tool_commands tool =
(* We get that by using the completion protocol, see doc/cli.mld *)
try
let subcommands cmd =
let rec find_subs = function
| "group" :: "Subcommands" :: lines ->
let rec subs acc = function
| "group" :: _ | [] -> acc
| "item" :: sub :: lines ->
let sub = if cmd = "" then sub else String.concat " " [cmd; sub]in
subs (sub :: acc) lines
| _ :: lines -> subs acc lines
in
subs [] lines
| _ :: lines -> find_subs lines
| [] -> []
in
let subs = if cmd = "" then [] else String.split_on_char ' ' cmd in
let args = "--__complete" :: (subs @ ["--__complete="]) in
let comps = exec_stdout tool ~args |> error_to_failure in
let comps = String.split_on_char '\n' comps in
match comps with
| "1" :: comps -> find_subs comps
| version :: comps ->
failwith (strf "Unsupported cmdliner completion protocol: %S" version)
| [] ->
failwith "Could not parse cmdliner completion protocol"
in
let rec loop acc = function
| cmd :: cmds ->
let subs = subcommands cmd in
loop (if cmd <> "" then cmd :: acc else acc) (List.rev_append subs cmds)
| [] -> List.sort String.compare acc
in
Ok (loop [] [""])
with Failure e -> Error e
let get_tool_command_man tool ~name cmd =
let man_basename =
let exec = if cmd = "" then name else String.concat " " [name; cmd] in
(String.map (function ' ' -> '-' | c -> c) exec)
in
let add_section man =
let rec extract_section = function
| line :: lines ->
begin match Scanf.sscanf line ".TH %s %d" (fun _ n -> n) with
| n -> Ok (n, man_basename, man)
| exception Scanf.Scan_failure _ -> extract_section lines
end
| [] ->
Error (strf "%s command: Could not extract section from manual"
(tool ^ " " ^ cmd))
in
extract_section (String.split_on_char '\n' man)
in
let subs = if cmd = "" then [] else String.split_on_char ' ' cmd in
let args = subs @ ["--help=groff"] in
match exec_stdout tool ~args with
| Error _ as e -> e
| Ok man -> add_section man
let get_tool_manpages tool ~name = match get_tool_commands tool with
| Error _ as e -> e
| Ok cmds ->
try
let man cmd = get_tool_command_man tool ~name cmd |> error_to_failure in
Ok (List.sort compare (List.map man ("" :: cmds)))
with
| Failure e -> Error e
(* File path actions *)
let log_action act p = Printf.printf "%s \x1B[1m%s\x1B[0m\n%!" act p
let mkdir ~dry_run p =
if not (Sys.file_exists p) then begin
log_action "Creating directory" p;
if not dry_run then mkdir p
end
let write_file ~dry_run p contents =
log_action "Writing" p;
if not dry_run then begin match write_file p contents with
| Ok () -> ()
| Error e -> failwith e
end
(* Shells completion *)
module type SHELL = sig
val name : string
val sharedir : string
val generic_script_name : string
val generic_completion : string
val tool_script_name : toolname:string -> string
val tool_completion : toolname:string -> string
end
type shell = (module SHELL)
module Bash = struct
let name = "bash"
let sharedir = "bash-completion/completions"
let generic_script_name = "_cmdliner_generic"
let generic_completion = Cmdliner_data.bash_generic_completion
let tool_script_name ~toolname = toolname
let tool_completion ~toolname = strf
{|if ! declare -F _cmdliner_generic > /dev/null; then
_completion_loader _cmdliner_generic
fi
complete -F _cmdliner_generic %s
|} toolname
end
module Zsh = struct
let name = "zsh"
let sharedir = "zsh/site-functions"
let generic_script_name = "_cmdliner_generic"
let generic_completion = Cmdliner_data.zsh_generic_completion
let tool_script_name ~toolname = "_" ^ toolname
let tool_completion ~toolname = strf
{|#compdef %s
autoload _cmdliner_generic
_cmdliner_generic
|} toolname
end
let shells : shell list = [(module Bash); (module Zsh)]
let generic_completion (module Shell : SHELL) =
with_binary_stdout @@ fun () ->
print_string Shell.generic_completion;
Cmdliner.Cmd.Exit.ok
let tool_completion (module Shell : SHELL) ~toolname =
with_binary_stdout @@ fun () ->
print_string (Shell.tool_completion ~toolname);
Cmdliner.Cmd.Exit.ok
(* Install commands *)
let install_generic_completion ~dry_run ~update_opam_install shells sharedir =
with_binary_stdout @@ fun () ->
let install ~dry_run sharedir acc (module Shell : SHELL) =
let rel_path = Filename.concat Shell.sharedir Shell.generic_script_name in
let dest = Filename.concat sharedir Shell.sharedir in
let path = Filename.concat sharedir rel_path in
mkdir ~dry_run dest;
write_file ~dry_run path Shell.generic_completion;
(path, rel_path) :: acc
in
try
let moves = List.fold_left (install ~dry_run sharedir) [] shells in
maybe_update_opam_install_file ~update_opam_install "share_root" moves;
Cmdliner.Cmd.Exit.ok
with Failure e -> prerr_endline e; Cmdliner.Cmd.Exit.some_error
let install_tool_completion
~dry_run ~update_opam_install ~shells ~toolnames ~sharedir
=
with_binary_stdout @@ fun () ->
let install ~dry_run ~toolnames sharedir acc (module Shell : SHELL) =
let write acc toolname =
let rel_path =
Filename.concat Shell.sharedir (Shell.tool_script_name ~toolname)
in
let path = Filename.concat sharedir rel_path in
write_file ~dry_run path (Shell.tool_completion ~toolname);
(path, rel_path) :: acc
in
mkdir ~dry_run (Filename.concat sharedir Shell.sharedir);
List.fold_left write acc toolnames
in
let moves = List.fold_left (install ~dry_run ~toolnames sharedir) [] shells in
try
maybe_update_opam_install_file ~update_opam_install "share_root" moves;
Cmdliner.Cmd.Exit.ok
with Failure e -> prerr_endline e; Cmdliner.Cmd.Exit.some_error
let install_tool_manpages ~dry_run ~update_opam_install ~tools ~mandir =
(* Note this correctly handles manpages sections but at the moment
all manpages for tool and commands are in section 1. *)
let rec get_mans tool =
let tool, name = split_toolname tool in
get_tool_manpages tool ~name |> error_to_failure
in
try
let mans = List.sort compare (List.concat (List.map get_mans tools)) in
let rec install ~dry_run ~last_sec acc = function
| (sec, basename, man) :: mans ->
let secdir = strf "man%d" sec in
let rel_path = Filename.concat secdir (strf "%s.%d" basename sec) in
let path = Filename.concat mandir rel_path in
if last_sec <> sec then mkdir ~dry_run (Filename.concat mandir secdir);
write_file ~dry_run path man;
install ~dry_run ~last_sec:sec ((path, rel_path) :: acc) mans
| [] -> acc
in
let moves = install ~dry_run ~last_sec:(-1) [] mans in
maybe_update_opam_install_file ~update_opam_install "man" moves;
Cmdliner.Cmd.Exit.ok
with Failure e -> prerr_endline e; Cmdliner.Cmd.Exit.some_error
let install_tool_support
~dry_run ~update_opam_install tools shells ~prefix ~sharedir ~mandir
=
let sharedir = match sharedir with
| None -> Filename.concat prefix "share" | Some sharedir -> sharedir
in
let mandir = match mandir with
| None -> Filename.concat sharedir "man" | Some mandir -> mandir
in
let rc = install_tool_manpages ~dry_run ~update_opam_install ~tools ~mandir in
if rc <> Cmdliner.Cmd.Exit.ok then rc else
let toolnames = List.map snd (List.map split_toolname tools) in
install_tool_completion
~dry_run ~update_opam_install ~shells ~toolnames ~sharedir
(* Tool command listing command *)
let tool_commands tool = match get_tool_commands tool with
| Ok subs -> List.iter print_endline subs; Cmdliner.Cmd.Exit.ok
| Error e -> prerr_endline e; Cmdliner.Cmd.Exit.some_error
(* Command line interface *)
open Cmdliner
open Cmdliner.Term.Syntax
let dry_run =
let doc = "Do not install, output paths that would be written." in
Arg.(value & flag & info ["dry-run"] ~doc)
let update_opam_install =
let doc =
"Update or create an opam $(b,.install) file $(docv) with install moves \
from the installed files to the corresponding opam install sections. \
Also performed if $(b,--dry-run) is specified."
in
Arg.(value & opt (some filepath) None &
info ["update-opam-install"] ~doc ~docv:"PKG.install")
let prefix =
let doc = "$(docv) is the install prefix. For example $(b,/usr/local)." in
Arg.(required & pos ~rev:true 0 (some dirpath) None &
info [] ~doc ~docv:"PREFIX")
let sharedir_doc = "$(docv) is the $(b,share) directory to install to."
let sharedir_docv = "SHAREDIR"
let sharedir_posn ~rev n =
Arg.(required & pos ~rev n (some dirpath) None &
info [] ~doc:sharedir_doc ~docv:sharedir_docv)
let sharedir_pos0 = sharedir_posn ~rev:false 0
let sharedir_poslast = sharedir_posn ~rev:true 0
let sharedir_opt =
let absent = "$(i,PREFIX)$(b,/share)" in
Arg.(value & opt (some dirpath) None &
info ["sharedir"] ~doc:sharedir_doc ~docv:sharedir_docv ~absent)
let mandir_doc = "$(docv) is the root $(b,man) directory to install to."
let mandir_docv = "MANDIR"
let mandir_poslast =
Arg.(required & pos ~rev:true 0 (some dirpath) None &
info [] ~doc:mandir_doc ~docv:mandir_docv)
let mandir_opt =
let absent = "$(i,SHAREDIR)$(b,/man)" in
Arg.(value & opt (some dirpath) None &
info ["mandir"] ~doc:mandir_doc ~docv:mandir_docv ~absent)
let shell_assoc = List.map (fun ((module S : SHELL) as s) -> S.name, s) shells
let shells_doc = Arg.doc_alts_enum shell_assoc
let shell_conv = Arg.enum ~docv:"SHELL" shell_assoc
let shell_doc = strf "$(docv) the shell to support, must be %s." shells_doc
let shells_opt =
let doc = shell_doc ^ " Repeatable." in
let absent = "All supported shells" in
Arg.(value & opt_all shell_conv shells & info ["s"; "shell"] ~absent ~doc)
let shell_posn n =
Arg.(required & pos n (some shell_conv) None & info [] ~doc:shell_doc)
let shell_pos0 = shell_posn 0
let shell_pos1 = shell_posn 1
let toolname_posn n =
let doc = "$(docv) is the name of the tool to complete." in
Arg.(required & pos n (some filepath) None & info [] ~doc ~docv:"TOOLNAME")
let toolname_pos0 = toolname_posn 0
let toolname_pos1 = toolname_posn 1
let toolnames_posleft =
let doc = "$(docv) is the name of the tool to complete. Repeatable." in
Arg.(non_empty & pos_left ~rev:true 0 string [] &
info [] ~doc ~docv:"TOOLNAME")
let tools_posleft =
let doc =
"$(i,TOOLEXEC) is the tool executable. Searched in the $(b,PATH) unless \
an explicit file path is specified. $(i,NAME) is the tool name, if \
unspecified derived from $(i,TOOLEXEC) by taking the basename and \
stripping any $(b,.exe) extension. Repeatable."
in
let docv = "TOOLEXEC[:NAME]" in
Arg.(non_empty & pos_left ~rev:true 0 filepath [] & info [] ~doc ~docv)
let generic_completion_cmd =
let doc = "Output generic completion scripts" in
let man =
[ `S Manpage.s_description;
`P "$(cmd) outputs the generic cmdliner completion script for a given \
shell. Examples:";
`Pre "$(cmd) $(b,zsh)"; `Noblank;
`Pre "$(b,eval) $(b,\\$\\()$(cmd) $(b,zsh\\))";
`P "The script needs to be loaded in a shell for tool specific \
scripts output by the command $(b,tool-completion) to work. See \
command $(b,install generic-completion) to install them.";
]
in
Cmd.make (Cmd.info "generic-completion" ~doc ~man) @@
let+ shell = shell_pos0 in
generic_completion shell
let tool_commands_cmd =
let doc = "Output all subcommands of a cmdliner tool" in
let man =
[ `S Manpage.s_description;
`P "$(cmd) outputs all the subcommands of a given cmdliner based \
tool, one per line. Examples:";
`Pre "$(cmd) $(b,./mytool)"; `Noblank;
`Pre "$(cmd) $(b,cmdliner)";
]
in
Cmd.make (Cmd.info "tool-commands" ~doc ~man) @@
let+ tool =
let doc =
"$(docv) is the tool executable. Searched in the $(b,PATH) unless \
an explicit file path is specified."
in
Arg.(required & pos 0 (some filepath) None & info [] ~doc ~docv:"TOOLEXEC")
in
tool_commands tool
let tool_completion_cmd =
let doc = "Output tool completion scripts" in
let man =
[ `S Manpage.s_description;
`P "$(cmd) outputs the tool specific completion script of a given shell. \
Example:";
`Pre "$(cmd) $(b,zsh mytool)";
`P "Note that tool specific completion script need the corresponding \
generic completion script output by $(b,generic-completion) to be \
loaded in the shell. To install these scripts see command \
$(b,install tool-completion).";
]
in
Cmd.make (Cmd.info "tool-completion" ~doc ~man) @@
let+ shell = shell_pos0 and+ toolname = toolname_pos1 in
tool_completion shell ~toolname
let install_generic_completion_cmd =
let doc = "Install generic completion scripts" in
let man = [
`S Manpage.s_description;
`P "$(cmd) installs the generic completion script of given shells in \
a $(b,share) directory according to specific shell conventions. \
Directories are created if needed. \
Use option $(b,--dry-run) to see which paths would be written. \
Examples:";
`Pre "$(cmd) $(b,/usr/local/share) # All supported shells"; `Noblank;
`Pre "$(cmd) $(b,--shell zsh /usr/local/share)";
`P "To inspect the actual scripts use the command \
$(b,generic-completion).";
]
in
Cmd.make (Cmd.info "generic-completion" ~doc ~man) @@
(* No let punning in < 4.13 *)
let+ dry_run = dry_run and+ shells = shells_opt
and+ update_opam_install = update_opam_install
and+ sharedir_pos0 = sharedir_pos0 in
install_generic_completion ~dry_run ~update_opam_install shells sharedir_pos0
let install_tool_completion_cmd =
let doc = "Install tool completion scripts" in
let man = [
`S Manpage.s_description;
`P "$(cmd) installs tool completion script of given tools and shells in \
a $(b,share) directory according to specific shell conventions. \
Directories are created if needed. \
Use option $(b,--dry-run) to see which paths would be written. \
Example:";
`Pre "$(cmd) $(b,mytool) $(b,/usr/local/share) # All supported shells";
`Noblank;
`Pre "$(cmd) $(b,--shell zsh mytool /usr/local/share)";
`P "Note that the command $(b,install tool-support) also installs \
completions like this command does. To inspect the actual scripts \
use the command $(b,tool-completion).";
]
in
Cmd.make (Cmd.info "tool-completion" ~doc ~man) @@
(* No let punning in < 4.13 *)
let+ dry_run = dry_run and+ shells = shells_opt
and+ update_opam_install = update_opam_install
and+ toolnames = toolnames_posleft and+ sharedir = sharedir_poslast in
install_tool_completion
~dry_run ~update_opam_install ~shells ~toolnames ~sharedir
let install_tool_manpages_cmd =
let doc = "Install tool and subcommand manpages" in
let man = [
`S Manpage.s_description;
`P "$(cmd) installs the manpages of the tool and its commands \
according in directories of a $(b,man) directory. Directories are \
created if needed. \
Use option $(b,--dry-run) to see which paths would be written. \
Example:";
`Pre "$(cmd) $(b,./mytool) $(b,/usr/local/share/man)";
`P "Note that the command $(b,install tool-support) also installs manpages \
like this command does."
]
in
Cmd.make (Cmd.info "tool-manpages" ~doc ~man) @@
let+ dry_run = dry_run and+ update_opam_install = update_opam_install
and+ tools = tools_posleft and+ mandir = mandir_poslast in
install_tool_manpages ~dry_run ~update_opam_install ~tools ~mandir
let install_tool_support_cmd =
let doc = "Install both tool completion and manpages" in
let man = [
`S Manpage.s_description;
`P "$(cmd) combines commands $(b,install tool-completion) and \
$(b,install tool-manpages) to install all tool support files \
in a given $(i,PREFIX) which is assumed to follow the Filesystem \
Hierarchy Standard.
Use options $(b,--sharedir) and/or $(b,--mandir) if that is
not the case (e.g. in $(b,opam) as of writing).
Use option $(b,--dry-run) to see which paths would be written. \
Example:";
`Pre "$(cmd) $(b,./mytool /usr/local)"; `Noblank;
`Pre "$(cmd) $(b,--update-opam-install=mypkg.install) \\\\ \n\
\ $(b,_build/mytool _build/prefix)";
]
in
Cmd.make (Cmd.info "tool-support" ~doc ~man) @@
let+ dry_run = dry_run and+ update_opam_install = update_opam_install
and+ shells = shells_opt and+ tools = tools_posleft and+ sharedir = sharedir_opt
and+ mandir = mandir_opt and+ prefix = prefix in
install_tool_support
~dry_run ~update_opam_install tools shells ~prefix ~sharedir ~mandir
let install_cmd =
let doc = "Install support files for cmdliner tools" in
let man =
[ `S Manpage.s_description;
`P "$(cmd) subcommands install cmdliner support files. \
See the library documentation or invoke \
subcommands with $(b,--help) for more details."; ]
in
Cmd.group (Cmd.info "install" ~doc ~man) @@
[install_generic_completion_cmd; install_tool_completion_cmd;
install_tool_manpages_cmd; install_tool_support_cmd]
let cmd =
let doc = "Helper tool for cmdliner based tools" in
let default = Term.(ret (const (`Help (`Pager, None)))) in
let man =
[ `S Manpage.s_description;
`P "$(tool) is a helper for tools using the cmdliner command line \
interface library. It helps with installing command line \
completion scripts and manpages. See the library documentation or \
invoke subcommands with $(b,--help) for more details."; ]
in
Cmd.group (Cmd.info "cmdliner" ~version:"v2.0.0+dune" ~doc ~man) ~default @@
[generic_completion_cmd; tool_commands_cmd; tool_completion_cmd; install_cmd]
let main () = Cmd.eval' cmd
let () = if !Sys.interactive then () else exit (main ())

72
unikernel/duniverse/cmdliner/src/tool/zsh-completion.sh Normal file
View file

@ -0,0 +1,72 @@
function _cmdliner_generic {
local w=("${words[@]}") # Keep words intact for restart completion
local prefix="${words[CURRENT]}"
w[CURRENT]="--__complete=${words[CURRENT]}"
local line="${w[@]:0:1} --__complete ${w[@]:1}"
local -a completions
local version type group item text_line item_doc msg
eval $line | {
read -r version
if [[ $version != "1" ]]; then
_message -r "Unsupported cmdliner completion protocol: $version"
return 1
fi
while IFS= read -r type; do
if [[ "$type" == "group" ]]; then
if [ -n "$completions" ]; then
_describe -V unsorted completions -U
completions=()
fi
read -r group
elif [[ "$type" == "message" ]]; then
msg="";
while read text_line; do
if [[ "$text_line" == "message-end" ]]; then
msg=${msg#?} # remove first newline
break
fi
msg+=$'\n'"$text_line"
done
_message -r "$msg"
elif [[ "$type" == "item" ]]; then
read -r item;
item_doc="";
while read -r text_line; do
if [[ "$text_line" == "item-end" ]]; then
item_doc=${item_doc#?} # remove first space
break
fi
# Sadly it seems impossible to make multiline
# doc strings. Get in touch if you know any better.
item_doc+=" $text_line"
done
# Handle glued forms, the completion item is the full option
if [[ "$group" == "Values" ]]; then
if [[ "$prefix" == --* ]]; then
item="${prefix%%=*}=${item}"
elif [[ "$prefix" == -* ]]; then
item="${prefix:0:2}${item}"
fi
fi
# item_doc="${item_doc//$'\e'\[(01m|04m|m)/}"
completions+=("${item}":"${item_doc}")
elif [[ "$type" == "dirs" ]]; then
_path_files -/
elif [[ "$type" == "files" ]]; then
_path_files -f
elif [[ "$type" == "restart" ]]; then
# N.B. only emitted if there is a -- token
while [[ $words[1] != "--" ]]; do
shift words
(( CURRENT-- ))
done
shift words
(( CURRENT-- ))
_normal
fi
done
}
if [ -n "$completions" ]; then
_describe -V unsorted completions -U
fi
}

35
unikernel/duniverse/cmdliner/test/blueprint_cmds.ml Normal file
View file

@ -0,0 +1,35 @@
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: CC0-1.0
---------------------------------------------------------------------------*)
let hey () = Cmdliner.Cmd.Exit.ok
let ho () = Cmdliner.Cmd.Exit.ok
open Cmdliner
open Cmdliner.Term.Syntax
let flag = Arg.(value & flag & info ["flag"] ~doc:"The flag")
let infile =
let doc = "$(docv) is the input file. Use $(b,-) for $(b,stdin)." in
Arg.(value & pos 0 file "-" & info [] ~doc ~docv:"FILE")
let hey_cmd =
let doc = "The hey command synopsis is TODO" in
Cmd.make (Cmd.info "hey" ~doc) @@
let+ unit = Term.const () in
ho ()
let ho_cmd =
let doc = "The ho command synopsis is TODO" in
Cmd.make (Cmd.info "ho" ~doc) @@
let+ unit = Term.const () in
ho unit
let cmd =
let doc = "The tool synopsis is TODO" in
Cmd.group (Cmd.info "TODO-toolname" ~version:"v2.0.0+dune" ~doc) @@
[hey_cmd; ho_cmd]
let main () = Cmd.eval' cmd
let () = if !Sys.interactive then () else exit (main ())

18
unikernel/duniverse/cmdliner/test/blueprint_min.ml Normal file
View file

@ -0,0 +1,18 @@
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: CC0-1.0
---------------------------------------------------------------------------*)
let tool () = Cmdliner.Cmd.Exit.ok
open Cmdliner
open Cmdliner.Term.Syntax
let cmd =
let doc = "The tool synopsis is TODO" in
Cmd.make (Cmd.info "TODO-toolname" ~doc) @@
let+ unit = Term.const () in
tool unit
let main () = Cmd.eval' cmd
let () = if !Sys.interactive then () else exit (main ())

33
unikernel/duniverse/cmdliner/test/blueprint_tool.ml Normal file
View file

@ -0,0 +1,33 @@
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: CC0-1.0
---------------------------------------------------------------------------*)
let exit_todo = 1
let tool ~flag ~infile = exit_todo
open Cmdliner
open Cmdliner.Term.Syntax
let flag = Arg.(value & flag & info ["flag"] ~doc:"The flag")
let infile =
let doc = "$(docv) is the input file. Use $(b,-) for $(b,stdin)." in
Arg.(value & pos 0 file "-" & info [] ~doc ~docv:"FILE")
let cmd =
let doc = "The tool synopsis is TODO" in
let man = [
`S Manpage.s_description;
`P "$(cmd) does TODO" ]
in
let exits =
Cmd.Exit.info exit_todo ~doc:"When there is stuff todo" ::
Cmd.Exit.defaults
in
Cmd.make (Cmd.info "TODO" ~version:"v2.0.0+dune" ~doc ~man ~exits) @@
let+ flag and+ infile in
tool ~flag ~infile
let main () = Cmd.eval' cmd
let () = if !Sys.interactive then () else exit (main ())

38
unikernel/duniverse/cmdliner/test/example_chorus.ml Normal file
View file

@ -0,0 +1,38 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: CC0-1.0
---------------------------------------------------------------------------*)
(* Implementation of the command *)
let chorus ~count msg = for i = 1 to count do print_endline msg done
(* Command line interface *)
open Cmdliner
open Cmdliner.Term.Syntax
let count =
let doc = "Repeat the message $(docv) times." in
Arg.(value & opt int 10 & info ["c"; "count"] ~doc ~docv:"COUNT")
let msg =
let env =
let doc = "Overrides the default message to print." in
Cmd.Env.info "CHORUS_MSG" ~doc
in
let doc = "The message to print." in
Arg.(value & pos 0 string "Revolt!" & info [] ~env ~doc ~docv:"MSG")
let chorus_cmd =
let doc = "Print a customizable message repeatedly" in
let man = [
`S Manpage.s_bugs;
`P "Email bug reports to <bugs@example.org>." ]
in
Cmd.make (Cmd.info "chorus" ~version:"v2.0.0+dune" ~doc ~man) @@
let+ count and+ msg in
chorus ~count msg
let main () = Cmd.eval chorus_cmd
let () = if !Sys.interactive then () else exit (main ())

58
unikernel/duniverse/cmdliner/test/example_cp.ml Normal file
View file

@ -0,0 +1,58 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: CC0-1.0
---------------------------------------------------------------------------*)
(* Implementation, we check the dest argument and print the args *)
let cp ~verbose ~recurse ~force srcs dest =
let many = List.length srcs > 1 in
if many && (not (Sys.file_exists dest) || not (Sys.is_directory dest))
then `Error (false, dest ^ ": not a directory") else
`Ok (Printf.printf
"verbose = %B\nrecurse = %B\nforce = %B\nsrcs = %s\ndest = %s\n"
verbose recurse force (String.concat ", " srcs) dest)
(* Command line interface *)
open Cmdliner
open Cmdliner.Term.Syntax
let verbose =
let doc = "Print file names as they are copied." in
Arg.(value & flag & info ["v"; "verbose"] ~doc)
let recurse =
let doc = "Copy directories recursively." in
Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc)
let force =
let doc = "If a destination file cannot be opened, remove it and try again."in
Arg.(value & flag & info ["f"; "force"] ~doc)
let srcs =
let doc = "Source file(s) to copy." in
Arg.(non_empty & pos_left ~rev:true 0 file [] & info [] ~docv:"SOURCE" ~doc)
let dest =
let doc = "Destination of the copy. Must be a directory if there is more \
than one $(i,SOURCE)." in
let docv = "DEST" in
Arg.(required & pos ~rev:true 0 (some string) None & info [] ~docv ~doc)
let cp_cmd =
let doc = "Copy files" in
let man_xrefs =
[`Tool "mv"; `Tool "scp"; `Page ("umask", 2); `Page ("symlink", 7)]
in
let man = [
`S Manpage.s_bugs;
`P "Email them to <bugs@example.org>."; ]
in
Cmd.make (Cmd.info "cp" ~version:"v2.0.0+dune" ~doc ~man ~man_xrefs) @@
Term.ret @@
let+ verbose and+ recurse and+ force and+ srcs and+ dest in
cp ~verbose ~recurse ~force srcs dest
let main () = Cmd.eval cp_cmd
let () = if !Sys.interactive then () else exit (main ())

156
unikernel/duniverse/cmdliner/test/example_darcs.ml Normal file
View file

@ -0,0 +1,156 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: CC0-1.0
---------------------------------------------------------------------------*)
(* Implementations, just print the args. *)
type verb = Normal | Quiet | Verbose
type copts = { debug : bool; verb : verb; prehook : string option }
let str = Printf.sprintf
let opt_str sv = function None -> "None" | Some v -> str "Some(%s)" (sv v)
let opt_str_str = opt_str (fun s -> s)
let verb_str = function
| Normal -> "normal" | Quiet -> "quiet" | Verbose -> "verbose"
let pr_copts oc copts = Printf.fprintf oc
"debug = %B\nverbosity = %s\nprehook = %s\n"
copts.debug (verb_str copts.verb) (opt_str_str copts.prehook)
let initialize copts repodir = Printf.printf
"%arepodir = %s\n" pr_copts copts repodir
let record copts name email all ask_deps files = Printf.printf
"%aname = %s\nemail = %s\nall = %B\nask-deps = %B\nfiles = %s\n"
pr_copts copts (opt_str_str name) (opt_str_str email) all ask_deps
(String.concat ", " files)
let help copts man_format cmds topic = match topic with
| None -> `Help (`Pager, None) (* help about the program. *)
| Some topic ->
let topics = "topics" :: "patterns" :: "environment" :: cmds in
let conv = Cmdliner.Arg.enum (List.rev_map (fun s -> (s, s)) topics) in
let parse = Cmdliner.Arg.Conv.parser conv in
match parse topic with
| Error e -> `Error (false, e)
| Ok t when t = "topics" -> List.iter print_endline topics; `Ok ()
| Ok t when List.mem t cmds -> `Help (man_format, Some t)
| Ok t ->
let page = (topic, 7, "", "", ""), [`S topic; `P "Say something";] in
`Ok (Cmdliner.Manpage.print man_format Format.std_formatter page)
open Cmdliner
open Cmdliner.Term.Syntax
(* Help sections common to all commands *)
let help_secs = [
`S Manpage.s_common_options;
`P "These options are common to all commands.";
`S "MORE HELP";
`P "Use $(tool) $(i,COMMAND) --help for help on a single command.";`Noblank;
`P "Use $(tool) $(b,help patterns) for help on patch matching."; `Noblank;
`P "Use $(tool) $(b,help environment) for help on environment variables.";
`S Manpage.s_bugs; `P "Check bug reports at http://bugs.example.org.";]
(* Options common to all commands *)
let copts debug verb prehook = { debug; verb; prehook }
let copts_t =
let docs = Manpage.s_common_options in
let debug =
let doc = "Give only debug output." in
Arg.(value & flag & info ["debug"] ~docs ~doc)
in
let verb =
let doc = "Suppress informational output." in
let quiet = Quiet, Arg.info ["q"; "quiet"] ~docs ~doc in
let doc = "Give verbose output." in
let verbose = Verbose, Arg.info ["v"; "verbose"] ~docs ~doc in
Arg.(last & vflag_all [Normal] [quiet; verbose])
in
let prehook =
let doc = "Specify command to run before this $(tool) command." in
Arg.(value & opt (some string) None & info ["prehook"] ~docs ~doc)
in
Term.(const copts $ debug $ verb $ prehook)
(* Commands *)
let sdocs = Manpage.s_common_options
let initialize_cmd =
let repodir =
let doc = "Run the program in repository directory $(docv)." in
Arg.(value & opt file Filename.current_dir_name & info ["repodir"]
~docv:"DIR" ~doc)
in
let doc = "make the current directory a repository" in
let man = [
`S Manpage.s_description;
`P "Turns the current directory into a Darcs repository. Any
existing files and subdirectories become …";
`Blocks help_secs; ]
in
Cmd.make (Cmd.info "initialize" ~doc ~sdocs ~man) @@
let+ copts_t and+ repodir in
initialize copts_t repodir
let record_cmd =
let pname =
let doc = "Name of the patch." in
Arg.(value & opt (some string) None & info ["m"; "patch-name"] ~docv:"NAME"
~doc)
in
let author =
let doc = "Specifies the author's identity." in
Arg.(value & opt (some string) None & info ["A"; "author"] ~docv:"EMAIL"
~doc)
in
let all =
let doc = "Answer yes to all patches." in
Arg.(value & flag & info ["a"; "all"] ~doc)
in
let ask_deps =
let doc = "Ask for extra dependencies." in
Arg.(value & flag & info ["ask-deps"] ~doc)
in
let files = Arg.(value & (pos_all file) [] & info [] ~docv:"FILE or DIR") in
let doc = "create a patch from unrecorded changes" in
let man =
[`S Manpage.s_description;
`P "Creates a patch from changes in the working tree. If you specify
a set of files…";
`Blocks help_secs; ]
in
Cmd.make (Cmd.info "record" ~doc ~sdocs ~man) @@
let+ copts_t and+ pname and+ author and+ all and+ ask_deps and+ files in
record copts_t pname author all ask_deps files
let help_cmd =
let topic =
let doc = "The topic to get help on. $(b,topics) lists the topics." in
Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc)
in
let doc = "display help about darcs and darcs commands" in
let man =
[`S Manpage.s_description;
`P "Prints help about darcs commands and other subjects…";
`Blocks help_secs; ]
in
Cmd.make (Cmd.info "help" ~doc ~man) @@
Term.ret @@
let+ copts_t and+ man_format = Arg.man_format
and+ choice_names = Term.choice_names and+ topic in
help copts_t man_format choice_names topic
let main_cmd =
let doc = "a revision control system" in
let man = help_secs in
let info = Cmd.info "darcs" ~version:"v2.0.0+dune" ~doc ~sdocs ~man in
let default = Term.(ret (const (fun _ -> `Help (`Pager, None)) $ copts_t)) in
Cmd.group info ~default [initialize_cmd; record_cmd; help_cmd]
let main () = Cmd.eval main_cmd
let () = if !Sys.interactive then () else exit (main ())

9
unikernel/duniverse/cmdliner/test/example_group.ml Normal file
View file

@ -0,0 +1,9 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: CC0-1.0
---------------------------------------------------------------------------*)
open Cmdliner
let main () = Cmd.eval Testing_cmdliner.sample_group_cmd
let () = if !Sys.interactive then () else exit (main ())

13
unikernel/duniverse/cmdliner/test/example_revolt1.ml Normal file
View file

@ -0,0 +1,13 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: CC0-1.0
---------------------------------------------------------------------------*)
let revolt () = print_endline "Revolt!"
open Cmdliner
let revolt_term = Term.app (Term.const revolt) (Term.const ())
let revolt_cmd = Cmd.v (Cmd.info "revolt") revolt_term
let main () = Cmd.eval revolt_cmd
let () = if !Sys.interactive then () else exit (main ())

17
unikernel/duniverse/cmdliner/test/example_revolt2.ml Normal file
View file

@ -0,0 +1,17 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: CC0-1.0
---------------------------------------------------------------------------*)
let revolt () = print_endline "Revolt!"
open Cmdliner
open Cmdliner.Term.Syntax
let cmd_revolt =
Cmd.make (Cmd.info "revolt") @@
let+ () = Term.const () in
revolt ()
let main () = Cmd.eval cmd_revolt
let () = if !Sys.interactive then () else exit (main ())

65
unikernel/duniverse/cmdliner/test/example_rm.ml Normal file
View file

@ -0,0 +1,65 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: CC0-1.0
---------------------------------------------------------------------------*)
(* Implementation of the command, we just print the args. *)
type prompt = Always | Once | Never
let prompt_str = function
| Always -> "always" | Once -> "once" | Never -> "never"
let rm ~prompt ~recurse files =
Printf.printf "prompt = %s\nrecurse = %B\nfiles = %s\n"
(prompt_str prompt) recurse (String.concat ", " files)
(* Command line interface *)
open Cmdliner
open Cmdliner.Term.Syntax
let files = Arg.(non_empty & pos_all file [] & info [] ~docv:"FILE")
let prompt =
let always =
let doc = "Prompt before every removal." in
Always, Arg.info ["i"] ~doc
in
let never =
let doc = "Ignore nonexistent files and never prompt." in
Never, Arg.info ["f"; "force"] ~doc
in
let once =
let doc = "Prompt once before removing more than three files, or when
removing recursively. Less intrusive than $(b,-i), while
still giving protection against most mistakes."
in
Once, Arg.info ["I"] ~doc
in
Arg.(last & vflag_all [Always] [always; never; once])
let recursive =
let doc = "Remove directories and their contents recursively." in
Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc)
let rm_cmd =
let doc = "Remove files or directories" in
let man = [
`S Manpage.s_description;
`P "$(cmd) removes each specified $(i,FILE). By default it does not
remove directories, to also remove them and their contents, use the
option $(b,--recursive) ($(b,-r) or $(b,-R)).";
`P "To remove a file whose name starts with a $(b,-), for example
$(b,-foo), use one of these commands:";
`Pre "$(cmd) $(b,-- -foo)"; `Noblank;
`Pre "$(cmd) $(b,./-foo)";
`P "$(cmd) removes symbolic links, not the files referenced by the
links.";
`S Manpage.s_bugs; `P "Report bugs to <bugs@example.org>.";
`S Manpage.s_see_also; `P "$(b,rmdir)(1), $(b,unlink)(2)" ]
in
Cmd.make (Cmd.info "rm" ~version:"v2.0.0+dune" ~doc ~man) @@
let+ prompt and+ recursive and+ files in
rm ~prompt ~recurse:recursive files
let main () = Cmd.eval rm_cmd
let () = if !Sys.interactive then () else exit (main ())

89
unikernel/duniverse/cmdliner/test/example_tail.ml Normal file
View file

@ -0,0 +1,89 @@
(*---------------------------------------------------------------------------
Copyright (c) 2011 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: CC0-1.0
---------------------------------------------------------------------------*)
(* Implementation of the command, we just print the args. *)
type loc = bool * int
type verb = Verbose | Quiet
type follow = Name | Descriptor
let str = Printf.sprintf
let opt_str sv = function None -> "None" | Some v -> str "Some(%s)" (sv v)
let loc_str (rev, k) = if rev then str "%d" k else str "+%d" k
let follow_str = function Name -> "name" | Descriptor -> "descriptor"
let verb_str = function Verbose -> "verbose" | Quiet -> "quiet"
let tail ~lines ~follow ~verb ~pid files =
Printf.printf
"lines = %s\nfollow = %s\nverb = %s\npid = %s\nfiles = %s\n"
(loc_str lines) (opt_str follow_str follow) (verb_str verb)
(opt_str string_of_int pid) (String.concat ", " files)
(* Command line interface *)
open Cmdliner
open Cmdliner.Term.Syntax
let loc_arg =
let parser s =
try
if s <> "" && s.[0] <> '+'
then Ok (true, int_of_string s)
else Ok (false, int_of_string (String.sub s 1 (String.length s - 1)))
with Failure _ -> Error "unable to parse integer"
in
let pp ppf p = Format.fprintf ppf "%s" (loc_str p) in
Arg.Conv.make ~docv:"N" ~parser ~pp ()
let lines =
let doc = "Output the last $(docv) lines or use $(i,+)$(docv) to start \
output after the $(i,N)-1th line."
in
Arg.(value & opt loc_arg (true, 10) & info ["n"; "lines"] ~docv:"N" ~doc)
let follow =
let doc = "Output appended data as the file grows. $(docv) specifies how \
the file should be tracked, by its $(b,name) or by its \
$(b,descriptor)."
in
let follow = Arg.enum ["name", Name; "descriptor", Descriptor] in
Arg.(value & opt (some follow) ~vopt:(Some Descriptor) None &
info ["f"; "follow"] ~docv:"ID" ~doc)
let verb =
let quiet =
let doc = "Never output headers giving file names." in
Quiet, Arg.info ["q"; "quiet"; "silent"] ~doc
in
let verbose =
let doc = "Always output headers giving file names." in
Verbose, Arg.info ["v"; "verbose"] ~doc
in
Arg.(last & vflag_all [Quiet] [quiet; verbose])
let pid =
let doc = "With -f, terminate after process $(docv) dies." in
Arg.(value & opt (some int) None & info ["pid"] ~docv:"PID" ~doc)
let files = Arg.(value & (pos_all non_dir_file []) & info [] ~docv:"FILE")
let tail_cmd =
let doc = "Display the last part of a file" in
let man = [
`S Manpage.s_description;
`P "$(cmd) prints the last lines of each $(i,FILE) to standard output. If
no file is specified reads standard input. The number of printed
lines can be specified with the $(b,-n) option.";
`S Manpage.s_bugs;
`P "Report them to <bugs@example.org>.";
`S Manpage.s_see_also;
`P "$(b,cat)(1), $(b,head)(1)" ]
in
Cmd.make (Cmd.info "tail" ~version:"v2.0.0+dune" ~doc ~man) @@
let+ lines and+ follow and+ verb and+ pid and+ files in
tail ~lines ~follow ~verb ~pid files
let main () = Cmd.eval tail_cmd
let () = if !Sys.interactive then () else exit (main ())

437
unikernel/duniverse/cmdliner/test/test_arg.ml Normal file
View file

@ -0,0 +1,437 @@
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
open B0_std
open B0_testing
open Cmdliner
open Cmdliner.Term.Syntax
(* The tests have the following structure:
let test =
let cmd = … (* A command definition *) in
(* A few snapshots of valid cli parses *)
parse …
(* A few snapshots of invalid cli parses *)
error …
(* A snapshot of a plain text version of the manual *)
Testing_cmdliner.snap_man … *)
(* Positional arguments *)
let test_pos_all =
Test.test "Arg.pos_all" @@ fun () ->
let cmd =
Cmd.make (Cmd.info "test_pos_all" ~doc:"Test pos all") @@
let+ all = Arg.(value & pos_all string [] & info [] ~docv:"THEARG") in
all
in
let parse = Testing_cmdliner.snap_parse Test.T.(list string) cmd in
let error err = Testing_cmdliner.snap_eval_error err cmd in
parse [] @@ __POS_OF__ [];
parse ["0"] @@ __POS_OF__ ["0"];
parse ["--"; "0"] @@ __POS_OF__ ["0"];
parse ["0";"1"] @@ __POS_OF__ ["0"; "1"];
parse ["0";"--"; "1"] @@ __POS_OF__ ["0"; "1"];
(**)
error `Term ["--opt"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_pos_all\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]… [\u{001B}[04mTHEARG\u{001B}[m]…\n\
test_pos_all: \u{001B}[31munknown\u{001B}[m option \u{001B}[01m--opt\u{001B}[m\n";
(**)
Testing_cmdliner.snap_man cmd @@ __POS_OF__
{|NAME
test_pos_all - Test pos all
SYNOPSIS
test_pos_all [OPTION]… [THEARG]…
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
EXIT STATUS
test_pos_all exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
|};
()
let test_pos_left =
Test.test "Arg.pos_left" @@ fun () ->
let cmd =
Cmd.make (Cmd.info "test_pos_left" ~doc:"Test pos left") @@
let+ left = Arg.(value & pos_left 2 string [] & info [] ~docv:"LEFT") in
left
in
let parse = Testing_cmdliner.snap_parse Test.T.(list string) cmd in
let error err = Testing_cmdliner.snap_eval_error err cmd in
parse [] @@ __POS_OF__ [];
parse ["--"] @@ __POS_OF__ [];
parse ["0"] @@ __POS_OF__ ["0"];
parse ["0"; "--"; "1" ] @@ __POS_OF__ ["0"; "1"];
parse ["0"; "1" ] @@ __POS_OF__ ["0"; "1"];
(**)
error `Term ["0"; "1"; "2"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_pos_left\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]… [\u{001B}[04mLEFT\u{001B}[m] [\u{001B}[04mLEFT\u{001B}[m]\n\
test_pos_left: \u{001B}[31mtoo many arguments\u{001B}[m, don't know what to do with \u{001B}[01m2\u{001B}[m\n";
(**)
Testing_cmdliner.snap_man cmd @@ __POS_OF__
{|NAME
test_pos_left - Test pos left
SYNOPSIS
test_pos_left [OPTION]… [LEFT] [LEFT]
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
EXIT STATUS
test_pos_left exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
|};
()
let test_pos_req =
Test.test "Arg.required & Arg.pos" @@ fun () ->
let cmd =
Cmd.make (Cmd.info "test_pos_req" ~doc:"Test pos req arguments") @@
let+ r1 = Arg.(required & pos 0 (some string) None & info [] ~docv:"R1")
and+ r2 = Arg.(required & pos 1 (some string) None & info [] ~docv:"R2")
and+ r3 = Arg.(required & pos 2 (some string) None & info [] ~docv:"R3")
and+ right =
Arg.(non_empty & pos_right 2 string [] & info [] ~docv:"RIGHT")
in
r1, r2, r3, right
in
let t = Test.T.(t4 string string string (list string)) in
let parse = Testing_cmdliner.snap_parse t cmd in
parse ["r1"; "r2"; "r3"; "r4"] @@ __POS_OF__ ("r1", "r2", "r3", ["r4"]);
parse ["r1"; "r2"; "r3"; "r4"; "r5"] @@ __POS_OF__
("r1", "r2", "r3", ["r4"; "r5"]);
(**)
let error = Testing_cmdliner.snap_eval_error `Term cmd in
error [] @@ __POS_OF__
"Usage: \u{001B}[01mtest_pos_req\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]… \u{001B}[04mR1\u{001B}[m \u{001B}[04mR2\u{001B}[m \u{001B}[04mR3\u{001B}[m \u{001B}[04mRIGHT\u{001B}[m…\n\
test_pos_req: required arguments \u{001B}[04mR1\u{001B}[m, \u{001B}[04mR2\u{001B}[m, \u{001B}[04mR3\u{001B}[m, \u{001B}[04mRIGHT\u{001B}[m are \u{001B}[31mmissing\u{001B}[m\n";
error ["r1"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_pos_req\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]… \u{001B}[04mR1\u{001B}[m \u{001B}[04mR2\u{001B}[m \u{001B}[04mR3\u{001B}[m \u{001B}[04mRIGHT\u{001B}[m…\n\
test_pos_req: required arguments \u{001B}[04mR2\u{001B}[m, \u{001B}[04mR3\u{001B}[m, \u{001B}[04mRIGHT\u{001B}[m are \u{001B}[31mmissing\u{001B}[m\n";
error ["r1"; "r2"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_pos_req\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]… \u{001B}[04mR1\u{001B}[m \u{001B}[04mR2\u{001B}[m \u{001B}[04mR3\u{001B}[m \u{001B}[04mRIGHT\u{001B}[m…\n\
test_pos_req: required arguments \u{001B}[04mR3\u{001B}[m, \u{001B}[04mRIGHT\u{001B}[m are \u{001B}[31mmissing\u{001B}[m\n";
error ["r1"; "r2"; "r3"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_pos_req\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]… \u{001B}[04mR1\u{001B}[m \u{001B}[04mR2\u{001B}[m \u{001B}[04mR3\u{001B}[m \u{001B}[04mRIGHT\u{001B}[m…\n\
test_pos_req: required argument \u{001B}[04mRIGHT\u{001B}[m is \u{001B}[31mmissing\u{001B}[m\n";
(**)
Testing_cmdliner.snap_man cmd @@ __POS_OF__
{|NAME
test_pos_req - Test pos req arguments
SYNOPSIS
test_pos_req [OPTION]… R1 R2 R3 RIGHT…
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
EXIT STATUS
test_pos_req exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
|};
()
let test_pos_left_right =
Test.test "Arg.pos_{left,right}" @@ fun () ->
let cmd =
Cmd.make (Cmd.info "test_pos" ~doc:"Test pos arguments") @@
let+ l = Arg.(value & pos_left 2 string [] & info [] ~docv:"LEFT")
and+ t = Arg.(value & pos 2 string "undefined" & info [] ~docv:"TWO")
and+ r = Arg.(value & pos_right 2 string [] & info [] ~docv:"RIGHT") in
(l, t, r)
in
let t = Test.T.(t3 (list string) string (list string)) in
let snap = Testing_cmdliner.snap_parse t cmd in
snap [] @@ __POS_OF__ ([], "undefined", []);
snap ["0"] @@ __POS_OF__ (["0"], "undefined", []);
snap ["0"; "1"] @@ __POS_OF__ (["0"; "1"], "undefined", []);
snap ["0"; "1"; "2"] @@ __POS_OF__ (["0"; "1"], "2", []);
snap ["0"; "1"; "2"; "3"] @@ __POS_OF__ (["0"; "1"], "2", ["3"]);
snap ["0"; "1"; "2"; "3"; "4"] @@ __POS_OF__ (["0"; "1"], "2", ["3"; "4"]);
(**)
Testing_cmdliner.snap_man cmd @@ __POS_OF__
{|NAME
test_pos - Test pos arguments
SYNOPSIS
test_pos [OPTION]… [LEFT] [LEFT] [TWO] [RIGHT]…
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
EXIT STATUS
test_pos exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
|}
;
()
let test_pos_left_right_rev =
Test.test "Arg.pos_{left,right} ~rev:true" @@ fun () ->
let cmd =
Cmd.make (Cmd.info "test_pos" ~doc:"Test pos arguments") @@
let rev = true in
let+ l = Arg.(value & pos_left 2 ~rev string [] & info [] ~docv:"LEFT")
and+ t = Arg.(value & pos 2 ~rev string "undefined" & info [] ~docv:"TWO")
and+ r = Arg.(value & pos_right 2 ~rev string [] & info [] ~docv:"RIGHT") in
(l, t, r)
in
let t = Test.T.(t3 (list string) string (list string)) in
let snap = Testing_cmdliner.snap_parse t cmd in
snap [] @@ __POS_OF__ ([], "undefined", []);
snap ["0"] @@ __POS_OF__ ([], "undefined", ["0"]);
snap ["0"; "1"] @@ __POS_OF__ ([], "undefined", ["0"; "1"]);
snap ["0"; "1"; "2"] @@ __POS_OF__ ([], "0", ["1"; "2"]);
snap ["0"; "1"; "2"; "3"] @@ __POS_OF__ (["0"], "1", ["2"; "3"]);
snap ["0"; "1"; "2"; "3"; "4"] @@ __POS_OF__ (["0"; "1"], "2", ["3"; "4"]);
snap ["0"; "1"; "2"; "3"; "4"; "5"] @@ __POS_OF__
(["0"; "1"; "2"], "3", ["4"; "5"]);
(**)
Testing_cmdliner.snap_man cmd @@ __POS_OF__
{|NAME
test_pos - Test pos arguments
SYNOPSIS
test_pos [OPTION]… [LEFT]… [TWO] [RIGHT] [RIGHT]
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
EXIT STATUS
test_pos exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
|};
()
(* Optional arguments *)
let test_opt_required =
Test.test "Arg.required & Arg.opt" @@ fun () ->
let cmd =
let doc = "Test optional required arguments (don't do this)" in
Cmd.make (Cmd.info "test_opt_req" ~doc) @@
let+ req =
Arg.(required & opt (some string) None & info ["r"; "req"] ~docv:"ARG")
in
req
in
let snap = Testing_cmdliner.snap_parse Test.T.string cmd in
snap ["-ra"] @@ __POS_OF__ "a";
snap ["--req"; "a"] @@ __POS_OF__ "a";
(**)
let error err = Testing_cmdliner.snap_eval_error err cmd in
error `Parse [] @@ __POS_OF__
"Usage: \u{001B}[01mtest_opt_req\u{001B}[m [\u{001B}[01m--help\u{001B}[m] \u{001B}[01m--req\u{001B}[m=\u{001B}[04mARG\u{001B}[m [\u{001B}[04mOPTION\u{001B}[m]…\n\
test_opt_req: required option \u{001B}[01m--req\u{001B}[m is \u{001B}[31mmissing\u{001B}[m\n";
error `Term ["a"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_opt_req\u{001B}[m [\u{001B}[01m--help\u{001B}[m] \u{001B}[01m--req\u{001B}[m=\u{001B}[04mARG\u{001B}[m [\u{001B}[04mOPTION\u{001B}[m]…\n\
test_opt_req: \u{001B}[31mtoo many arguments\u{001B}[m, don't know what to do with \u{001B}[01ma\u{001B}[m\n";
error `Term ["-ra"; "a"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_opt_req\u{001B}[m [\u{001B}[01m--help\u{001B}[m] \u{001B}[01m--req\u{001B}[m=\u{001B}[04mARG\u{001B}[m [\u{001B}[04mOPTION\u{001B}[m]…\n\
test_opt_req: \u{001B}[31mtoo many arguments\u{001B}[m, don't know what to do with \u{001B}[01ma\u{001B}[m\n";
error `Parse ["-r"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_opt_req\u{001B}[m [\u{001B}[01m--help\u{001B}[m] \u{001B}[01m--req\u{001B}[m=\u{001B}[04mARG\u{001B}[m [\u{001B}[04mOPTION\u{001B}[m]…\n\
test_opt_req: option \u{001B}[01m-r\u{001B}[m \u{001B}[31mneeds an argument\u{001B}[m\n";
(**)
Testing_cmdliner.snap_man cmd @@ __POS_OF__
{|NAME
test_opt_req - Test optional required arguments (don't do this)
SYNOPSIS
test_opt_req --req=ARG [OPTION]…
OPTIONS
-r ARG, --req=ARG (required)
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
EXIT STATUS
test_opt_req exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
|};
()
let test_arg_info_docv =
Test.test "Arg.info default's docv on strings" @@ fun () ->
let cmd =
Cmd.make (Cmd.info "test_arg_docv" ~doc:"Test pos all") @@
let+ all = Arg.(value & pos_all string [] & info [])
and+ opt = Arg.(value & opt string "bla" & info ["field"]) in
all, opt
in
let error err = Testing_cmdliner.snap_eval_error err cmd in
(**)
error `Term ["-z"; "a"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_arg_docv\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[01m--field\u{001B}[m=\u{001B}[04mVAL\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]… [\u{001B}[04mARG\u{001B}[m]…\n\
test_arg_docv: \u{001B}[31munknown\u{001B}[m option \u{001B}[01m-z\u{001B}[m\n";
(**)
Testing_cmdliner.snap_man cmd @@ __POS_OF__
{|NAME
test_arg_docv - Test pos all
SYNOPSIS
test_arg_docv [--field=VAL] [OPTION]… [ARG]…
OPTIONS
--field=VAL (absent=bla)
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
EXIT STATUS
test_arg_docv exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
|};
()
let test_conv_docv =
Test.test "Arg.Conv.docv" @@ fun () ->
let cmd =
let field = Arg.Conv.of_conv Arg.string ~docv:"FIELD" in
Cmd.make (Cmd.info "test_conv_docv" ~doc:"Test conv docv") @@
let+ all = Arg.(value & pos_all field [] & info [])
and+ opt = Arg.(value & opt field "bla" & info ["field"]) in
all, opt
in
let error err = Testing_cmdliner.snap_eval_error err cmd in
(**)
error `Term ["-z"; "a"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_conv_docv\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[01m--field\u{001B}[m=\u{001B}[04mFIELD\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]… [\u{001B}[04mFIELD\u{001B}[m]…\n\
test_conv_docv: \u{001B}[31munknown\u{001B}[m option \u{001B}[01m-z\u{001B}[m\n";
(**)
Testing_cmdliner.snap_man cmd @@ __POS_OF__
{|NAME
test_conv_docv - Test conv docv
SYNOPSIS
test_conv_docv [--field=FIELD] [OPTION]… [FIELD]…
OPTIONS
--field=FIELD (absent=bla)
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
EXIT STATUS
test_conv_docv exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
|};
()
let test_arg_file =
Test.test "Arg.file" @@ fun () ->
let cmd =
Cmd.make (Cmd.info "test_arg_file" ~doc:"Test conv docv") @@
let+ all = Arg.(value & pos_all file [] & info []) in
all
in
let error err = Testing_cmdliner.snap_eval_error err cmd in
let parse = Testing_cmdliner.snap_parse Test.T.(list string) cmd in
parse ["-"] @@ __POS_OF__ ["-"];
(**)
error `Term ["-z"; "a"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_arg_file\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]… [\u{001B}[04mPATH\u{001B}[m]…\n\
test_arg_file: \u{001B}[31munknown\u{001B}[m option \u{001B}[01m-z\u{001B}[m\n";
(**)
Testing_cmdliner.snap_man cmd @@ __POS_OF__
{|NAME
test_arg_file - Test conv docv
SYNOPSIS
test_arg_file [OPTION]… [PATH]…
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
EXIT STATUS
test_arg_file exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
|};
()
let main () =
let doc = "Test argument specifications" in
Test.main ~doc @@ fun () -> Test.autorun ()
let () = if !Sys.interactive then () else exit (main ())

358
unikernel/duniverse/cmdliner/test/test_cmd.ml Normal file
View file

@ -0,0 +1,358 @@
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
open B0_std
open B0_testing
open Cmdliner
open Cmdliner.Term.Syntax
(* The tests have the following structure:
let test =
let cmd = … (* A command definition *) in
(* A few snapshots of valid cli parses *)
parse …
(* A few snapshots of invalid cli parses *)
error …
(* A snapshot of a plain text version of the manual *)
Testing_cmdliner.snap_man … *)
let test_groups =
Test.test "Cmd.group" @@ fun () ->
let cmd = Testing_cmdliner.sample_group_cmd in
let parse = Testing_cmdliner.snap_parse Test.T.unit cmd in
let error err = Testing_cmdliner.snap_eval_error err cmd in
let warning = Testing_cmdliner.snap_parse_warnings cmd in
parse ["birds"] @@ __POS_OF__ ();
parse ["birds"] @@ __POS_OF__ ();
parse ["birds"; "fly"] @@ __POS_OF__ ();
parse ["birds"; "land"] @@ __POS_OF__ ();
parse ["mammals"] @@ __POS_OF__ ();
(**)
warning ["camels"] @@ __POS_OF__
"test_group: \u{001B}[33mdeprecated\u{001B}[m command \u{001B}[01mcamels\u{001B}[m: Use \u{001B}[01mmammals\u{001B}[m instead.\n";
(**)
error `Term [] @@ __POS_OF__
"Usage: \u{001B}[01mtest_group\u{001B}[m [\u{001B}[01m--help\u{001B}[m] \u{001B}[04mCOMMAND\u{001B}[m …\n\
test_group: required \u{001B}[04mCOMMAND\u{001B}[m name is \u{001B}[31mmissing\u{001B}[m, must be one of \u{001B}[01mbirds\u{001B}[m, \u{001B}[01mcamels\u{001B}[m,\n\
\ \u{001B}[01mfishs\u{001B}[m, \u{001B}[01mlookup\u{001B}[m or \u{001B}[01mmammals\u{001B}[m\n";
error `Term ["bla"] @@ __POS_OF__ "Usage: \u{001B}[01mtest_group\u{001B}[m [\u{001B}[01m--help\u{001B}[m] \u{001B}[04mCOMMAND\u{001B}[m …\n\
test_group: \u{001B}[31munknown\u{001B}[m command \u{001B}[01mbla\u{001B}[m. Must be one of \u{001B}[01mbirds\u{001B}[m, \u{001B}[01mcamels\u{001B}[m, \u{001B}[01mfishs\u{001B}[m, \u{001B}[01mlookup\u{001B}[m\n\
\ or \u{001B}[01mmammals\u{001B}[m\n";
error `Parse ["birds"; "-k"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_group birds\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[04mCOMMAND\u{001B}[m] …\n\
test_group: option \u{001B}[01m-k\u{001B}[m \u{001B}[31mneeds an argument\u{001B}[m\n";
error `Term ["mammals"; "land"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_group mammals\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]…\n\
test_group: \u{001B}[31mtoo many arguments\u{001B}[m, don't know what to do with \u{001B}[01mland\u{001B}[m\n";
(**)
Testing_cmdliner.snap_man cmd @@ __POS_OF__
{|NAME
test_group
SYNOPSIS
test_group COMMAND …
Invoke command with test_group, the command name is test_group, the
parent is test_group and the tool name is test_group.
COMMANDS
birds [COMMAND] …
Operate on birds.
fishs [OPTION]… [NAME]
Operate on fishs.
lookup [--kind=ENUM] [OPTION]… NAME
Lookup animal by name.
mammals [OPTION]…
Operate on mammals.
(Deprecated) camels [--bactrian] [OPTION]… [HERD]
Use mammals instead. Operate on camels.
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
--version
Show version information.
EXIT STATUS
test_group exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
|};
Testing_cmdliner.snap_man ~args:["birds"; "--help=plain"] cmd @@ __POS_OF__
{|NAME
test_group-birds - Operate on birds.
SYNOPSIS
test_group birds [COMMAND] …
Invoke command with test_group birds, the command name is birds, the
parent is test_group and the tool name is test_group.
COMMANDS
fly [--speed=SPEED] [OPTION]… [BIRD]
Fly birds.
land [OPTION]… [BIRD]
Land birds.
OPTIONS
--can-fly=BOOL (absent=false)
BOOL indicates if the entity can fly.
-k VAL, --kind=VAL
Kind of entity
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
--version
Show version information.
EXIT STATUS
test_group birds exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
125 on unexpected internal errors (bugs).
SEE ALSO|};
();
Testing_cmdliner.snap_man ~args:["birds"; "fly"; "--help=plain"] cmd @@
__POS_OF__
{|NAME
test_group-birds-fly - Fly birds.
SYNOPSIS
test_group birds fly [--speed=SPEED] [OPTION]… [BIRD]
Invoke command with test_group birds fly, the command name is fly, the
parent is test_group birds and the tool name is test_group.
ARGUMENTS
BIRD (absent=pigeon)
Use BIRD specie.
OPTIONS
--speed=SPEED (absent=2)
Movement SPEED in m/s
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
--version
Show version information.
EXIT STATUS
test_group birds fly exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
125 on unexpected internal errors (bugs).
SEE ALSO|};
Testing_cmdliner.snap_man ~args:["birds"; "land"; "--help=plain"] cmd @@
__POS_OF__
{|NAME
test_group-birds-land - Land birds.
SYNOPSIS
test_group birds land [OPTION]… [BIRD]
Invoke command with test_group birds land, the command name is land,
the parent is test_group birds and the tool name is test_group.
ARGUMENTS
BIRD (absent=pigeon)
Use BIRD specie.
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
--version
Show version information.
EXIT STATUS
test_group birds land exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
125 on unexpected internal errors (bugs).
SEE ALSO|};
();
Testing_cmdliner.snap_man ~args:["fishs"; "--help=plain"] cmd @@
__POS_OF__
{|NAME
test_group-fishs - Operate on fishs.
SYNOPSIS
test_group fishs [OPTION]… [NAME]
Invoke command with test_group fishs, the command name is fishs, the
parent is test_group and the tool name is test_group.
ARGUMENTS
NAME
Use fish named NAME.
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
--version
Show version information.
EXIT STATUS
test_group fishs exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
125 on unexpected internal errors (bugs).
SEE ALSO|};
Testing_cmdliner.snap_man ~args:["mammals"; "--help=plain"] cmd @@
__POS_OF__
{|NAME
test_group-mammals - Operate on mammals.
SYNOPSIS
test_group mammals [OPTION]…
Invoke command with test_group mammals, the command name is mammals,
the parent is test_group and the tool name is test_group.
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
--version
Show version information.
EXIT STATUS
test_group mammals exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
125 on unexpected internal errors (bugs).
SEE ALSO|};
Testing_cmdliner.snap_man ~args:["camels"; "--help=plain"] cmd @@
__POS_OF__
{|NAME
(Deprecated) test_group-camels - Use mammals instead. Operate on
camels.
SYNOPSIS
(Deprecated) test_group camels [--bactrian] [OPTION]… [HERD]
Invoke command with test_group camels, the command name is camels, the
parent is test_group and the tool name is test_group.
ARGUMENTS
(Deprecated) HERD
Herds HERD are ignored. Find in herd HERD.
OPTIONS
(Deprecated) -b, --bactrian (absent BACTRIAN env)
Use nothing instead of BACTRIAN, HA!. Specify a bactrian camel.
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
--version
Show version information.
EXIT STATUS
test_group camels exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
125 on unexpected internal errors (bugs).
ENVIRONMENT
These environment variables affect the execution of test_group camels:
(Deprecated) BACTRIAN
Use nothing instead of BACTRIAN, HA!. See option --bactrian.
SEE ALSO|};
()
let test_std_opts =
Test.test "Standard options" @@ fun () ->
let cmd = Testing_cmdliner.sample_group_cmd in
let snap_version = Testing_cmdliner.snap_help (Ok `Version) cmd in
let ret ?__POS__ =
let env = Testing_cmdliner.env_dumb_term in
Testing_cmdliner.test_eval_result ?__POS__ ~env Test.T.unit cmd
in
snap_version ["--version"] @@ __POS_OF__ "X.Y.Z\n";
snap_version ["--version"; "birds"] @@ __POS_OF__ "X.Y.Z\n";
snap_version ["fishs"; "--version"; "birds"] @@ __POS_OF__ "X.Y.Z\n";
ret ["--help"; "--version"] (Ok `Help) ~__POS__;
ret ["--help"; "--version"] (Ok `Help) ~__POS__;
ret ["fishs"; "--version"; "birds"; "--help"] (Ok `Help) ~__POS__;
ret ["--help"; "crow"] (Ok `Help) ~__POS__;
ret ["birds"; "--help"; "crow"] (Ok `Help) ~__POS__;
ret ["fishs"; "--"; "--help"] (Ok (`Ok ())) ~__POS__;
()
let main () =
let doc = "Test command specifications" in
Test.main ~doc @@ fun () -> Test.autorun ()
let () = if !Sys.interactive then () else exit (main ())

635
unikernel/duniverse/cmdliner/test/test_completion.ml Normal file
View file

@ -0,0 +1,635 @@
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
open B0_std
open B0_testing
open Cmdliner
open Cmdliner.Term.Syntax
(* The tests have the following structure:
let test =
let cmd = … (* A command definition *) in
(* A few snapshots of completion protocol results *)
complete … *)
let cmd = Testing_cmdliner.sample_group_cmd
let complete = Testing_cmdliner.snap_completion cmd
let test_groups =
Test.test "Cmd.group completions" @@ fun () ->
complete ["--__complete="] @@ __POS_OF__
"1\n\
group\n\
Options\n\
item\n\
--version\n\
Show version information.\n\
item-end\n\
item\n\
--help\n\
Show this help in format \u{001B}[04mFMT\u{001B}[m. The value \u{001B}[04mFMT\u{001B}[m must be one of \u{001B}[01mauto\u{001B}[m, \u{001B}[01mpager\u{001B}[m, \u{001B}[01mgroff\u{001B}[m\n\
or \u{001B}[01mplain\u{001B}[m. With \u{001B}[01mauto\u{001B}[m, the format is \u{001B}[01mpager\u{001B}[m or \u{001B}[01mplain\u{001B}[m whenever the \u{001B}[01mTERM\u{001B}[m env var\n\
is \u{001B}[01mdumb\u{001B}[m or undefined.\n\
item-end\n\
group\n\
Subcommands\n\
item\n\
birds\n\
Operate on birds.\n\
item-end\n\
item\n\
mammals\n\
Operate on mammals.\n\
item-end\n\
item\n\
fishs\n\
Operate on fishs.\n\
item-end\n\
item\n\
camels\n\
Operate on camels.\n\
item-end\n\
item\n\
lookup\n\
Lookup animal by name.\n\
item-end\n";
complete ["birds"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Options\n\
item\n\
-k\n\
Kind of entity\n\
item-end\n\
item\n\
--kind\n\
Kind of entity\n\
item-end\n\
item\n\
--can-fly\n\
\u{001B}[04mBOOL\u{001B}[m indicates if the entity can fly.\n\
item-end\n\
item\n\
--version\n\
Show version information.\n\
item-end\n\
item\n\
--help\n\
Show this help in format \u{001B}[04mFMT\u{001B}[m. The value \u{001B}[04mFMT\u{001B}[m must be one of \u{001B}[01mauto\u{001B}[m, \u{001B}[01mpager\u{001B}[m, \u{001B}[01mgroff\u{001B}[m\n\
or \u{001B}[01mplain\u{001B}[m. With \u{001B}[01mauto\u{001B}[m, the format is \u{001B}[01mpager\u{001B}[m or \u{001B}[01mplain\u{001B}[m whenever the \u{001B}[01mTERM\u{001B}[m env var\n\
is \u{001B}[01mdumb\u{001B}[m or undefined.\n\
item-end\n\
group\n\
Subcommands\n\
item\n\
fly\n\
Fly birds.\n\
item-end\n\
item\n\
land\n\
Land birds.\n\
item-end\n";
()
let test_no_options_after_dashsash =
Test.test "no options after --" @@ fun () ->
complete ["birds"; "fly"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Options\n\
item\n\
--speed\n\
Movement \u{001B}[04mSPEED\u{001B}[m in m/s\n\
item-end\n\
item\n\
--version\n\
Show version information.\n\
item-end\n\
item\n\
--help\n\
Show this help in format \u{001B}[04mFMT\u{001B}[m. The value \u{001B}[04mFMT\u{001B}[m must be one of \u{001B}[01mauto\u{001B}[m, \u{001B}[01mpager\u{001B}[m, \u{001B}[01mgroff\u{001B}[m\n\
or \u{001B}[01mplain\u{001B}[m. With \u{001B}[01mauto\u{001B}[m, the format is \u{001B}[01mpager\u{001B}[m or \u{001B}[01mplain\u{001B}[m whenever the \u{001B}[01mTERM\u{001B}[m env var\n\
is \u{001B}[01mdumb\u{001B}[m or undefined.\n\
item-end\n";
complete ["birds"; "fly"; "--"; "--__complete="] @@ __POS_OF__
"1\n";
()
let test_opts_starts =
Test.test "complete optional argument names" @@ fun () ->
complete ["birds"; "--__complete=-"] @@ __POS_OF__
"1\n\
group\n\
Options\n\
item\n\
-k\n\
Kind of entity\n\
item-end\n\
item\n\
--kind\n\
Kind of entity\n\
item-end\n\
item\n\
--can-fly\n\
\u{001B}[04mBOOL\u{001B}[m indicates if the entity can fly.\n\
item-end\n\
item\n\
--version\n\
Show version information.\n\
item-end\n\
item\n\
--help\n\
Show this help in format \u{001B}[04mFMT\u{001B}[m. The value \u{001B}[04mFMT\u{001B}[m must be one of \u{001B}[01mauto\u{001B}[m, \u{001B}[01mpager\u{001B}[m, \u{001B}[01mgroff\u{001B}[m\n\
or \u{001B}[01mplain\u{001B}[m. With \u{001B}[01mauto\u{001B}[m, the format is \u{001B}[01mpager\u{001B}[m or \u{001B}[01mplain\u{001B}[m whenever the \u{001B}[01mTERM\u{001B}[m env var\n\
is \u{001B}[01mdumb\u{001B}[m or undefined.\n\
item-end\n\
group\n\
Subcommands\n";
complete ["birds"; "--__complete=--"] @@ __POS_OF__
"1\n\
group\n\
Options\n\
item\n\
--kind\n\
Kind of entity\n\
item-end\n\
item\n\
--can-fly\n\
\u{001B}[04mBOOL\u{001B}[m indicates if the entity can fly.\n\
item-end\n\
item\n\
--version\n\
Show version information.\n\
item-end\n\
item\n\
--help\n\
Show this help in format \u{001B}[04mFMT\u{001B}[m. The value \u{001B}[04mFMT\u{001B}[m must be one of \u{001B}[01mauto\u{001B}[m, \u{001B}[01mpager\u{001B}[m, \u{001B}[01mgroff\u{001B}[m\n\
or \u{001B}[01mplain\u{001B}[m. With \u{001B}[01mauto\u{001B}[m, the format is \u{001B}[01mpager\u{001B}[m or \u{001B}[01mplain\u{001B}[m whenever the \u{001B}[01mTERM\u{001B}[m env var\n\
is \u{001B}[01mdumb\u{001B}[m or undefined.\n\
item-end\n";
()
let test_opt_value =
Test.test "complete optional argument values" @@ fun () ->
(* Glued *)
complete ["birds"; "--__complete=--can-fly="] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
true\n\
\n\
item-end\n\
item\n\
false\n\
\n\
item-end\n";
(* next token *)
complete ["birds"; "--can-fly"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
true\n\
\n\
item-end\n\
item\n\
false\n\
\n\
item-end\n";
complete ["birds"; "--can-fly=true"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Options\n\
item\n\
-k\n\
Kind of entity\n\
item-end\n\
item\n\
--kind\n\
Kind of entity\n\
item-end\n\
item\n\
--can-fly\n\
\u{001B}[04mBOOL\u{001B}[m indicates if the entity can fly.\n\
item-end\n\
item\n\
--version\n\
Show version information.\n\
item-end\n\
item\n\
--help\n\
Show this help in format \u{001B}[04mFMT\u{001B}[m. The value \u{001B}[04mFMT\u{001B}[m must be one of \u{001B}[01mauto\u{001B}[m, \u{001B}[01mpager\u{001B}[m, \u{001B}[01mgroff\u{001B}[m\n\
or \u{001B}[01mplain\u{001B}[m. With \u{001B}[01mauto\u{001B}[m, the format is \u{001B}[01mpager\u{001B}[m or \u{001B}[01mplain\u{001B}[m whenever the \u{001B}[01mTERM\u{001B}[m env var\n\
is \u{001B}[01mdumb\u{001B}[m or undefined.\n\
item-end\n";
complete ["birds"; "--can-fly"; "true"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Options\n\
item\n\
-k\n\
Kind of entity\n\
item-end\n\
item\n\
--kind\n\
Kind of entity\n\
item-end\n\
item\n\
--can-fly\n\
\u{001B}[04mBOOL\u{001B}[m indicates if the entity can fly.\n\
item-end\n\
item\n\
--version\n\
Show version information.\n\
item-end\n\
item\n\
--help\n\
Show this help in format \u{001B}[04mFMT\u{001B}[m. The value \u{001B}[04mFMT\u{001B}[m must be one of \u{001B}[01mauto\u{001B}[m, \u{001B}[01mpager\u{001B}[m, \u{001B}[01mgroff\u{001B}[m\n\
or \u{001B}[01mplain\u{001B}[m. With \u{001B}[01mauto\u{001B}[m, the format is \u{001B}[01mpager\u{001B}[m or \u{001B}[01mplain\u{001B}[m whenever the \u{001B}[01mTERM\u{001B}[m env var\n\
is \u{001B}[01mdumb\u{001B}[m or undefined.\n\
item-end\n";
()
let test_context_sensitive =
Test.test "context sensitive completions" @@ fun () ->
complete ["lookup"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
sparrow\n\
\n\
item-end\n\
item\n\
parrot\n\
\n\
item-end\n\
item\n\
pigeon\n\
\n\
item-end\n\
item\n\
salmon\n\
\n\
item-end\n\
item\n\
trout\n\
\n\
item-end\n\
item\n\
piranha\n\
\n\
item-end\n\
group\n\
Options\n\
item\n\
-k\n\
\u{001B}[04mENUM\u{001B}[m restricts the animal kind. Must be either \u{001B}[01mbird\u{001B}[m or \u{001B}[01mfish\u{001B}[m\n\
item-end\n\
item\n\
--kind\n\
\u{001B}[04mENUM\u{001B}[m restricts the animal kind. Must be either \u{001B}[01mbird\u{001B}[m or \u{001B}[01mfish\u{001B}[m\n\
item-end\n\
item\n\
--version\n\
Show version information.\n\
item-end\n\
item\n\
--help\n\
Show this help in format \u{001B}[04mFMT\u{001B}[m. The value \u{001B}[04mFMT\u{001B}[m must be one of \u{001B}[01mauto\u{001B}[m, \u{001B}[01mpager\u{001B}[m, \u{001B}[01mgroff\u{001B}[m\n\
or \u{001B}[01mplain\u{001B}[m. With \u{001B}[01mauto\u{001B}[m, the format is \u{001B}[01mpager\u{001B}[m or \u{001B}[01mplain\u{001B}[m whenever the \u{001B}[01mTERM\u{001B}[m env var\n\
is \u{001B}[01mdumb\u{001B}[m or undefined.\n\
item-end\n";
complete ["lookup"; "-kfish"; "--__complete=s"] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
salmon\n\
\n\
item-end\n";
complete ["lookup"; "-kbird"; "--__complete=p"] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
parrot\n\
\n\
item-end\n\
item\n\
pigeon\n\
\n\
item-end\n";
()
let test_restart_restricted_tool =
Test.test "restart restricted tool" @@ fun () ->
let cmd =
Cmd.make (Cmd.info "test_restart_restricted") @@
let+ verb = Arg.(value & flag & info ["verbose"])
and+ tool =
let tool = Arg.enum ~docv:"VCS" ["git", `Git; "hg", `Hg] in
Arg.(required & pos 0 (some tool) None & info [])
and+ args =
let arg =
let completion = Arg.Completion.complete_restart in
Arg.Conv.of_conv Arg.string ~docv:"ARG" ~completion
in
Arg.(value & pos_right 0 arg [] & info [])
in
()
in
let complete = Testing_cmdliner.snap_completion cmd in
complete ["--__complete="] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
git\n\
\n\
item-end\n\
item\n\
hg\n\
\n\
item-end\n\
group\n\
Options\n\
item\n\
--verbose\n\
\n\
item-end\n\
item\n\
--help\n\
Show this help in format \u{001B}[04mFMT\u{001B}[m. The value \u{001B}[04mFMT\u{001B}[m must be one of \u{001B}[01mauto\u{001B}[m, \u{001B}[01mpager\u{001B}[m, \u{001B}[01mgroff\u{001B}[m\n\
or \u{001B}[01mplain\u{001B}[m. With \u{001B}[01mauto\u{001B}[m, the format is \u{001B}[01mpager\u{001B}[m or \u{001B}[01mplain\u{001B}[m whenever the \u{001B}[01mTERM\u{001B}[m env var\n\
is \u{001B}[01mdumb\u{001B}[m or undefined.\n\
item-end\n";
complete ["--__complete=g"] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
git\n\
\n\
item-end\n";
(* Note no reset here: as there is no -- token *)
complete ["git"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Options\n\
item\n\
--verbose\n\
\n\
item-end\n\
item\n\
--help\n\
Show this help in format \u{001B}[04mFMT\u{001B}[m. The value \u{001B}[04mFMT\u{001B}[m must be one of \u{001B}[01mauto\u{001B}[m, \u{001B}[01mpager\u{001B}[m, \u{001B}[01mgroff\u{001B}[m\n\
or \u{001B}[01mplain\u{001B}[m. With \u{001B}[01mauto\u{001B}[m, the format is \u{001B}[01mpager\u{001B}[m or \u{001B}[01mplain\u{001B}[m whenever the \u{001B}[01mTERM\u{001B}[m env var\n\
is \u{001B}[01mdumb\u{001B}[m or undefined.\n\
item-end\n";
complete ["--"; "git"; "--__complete="] @@ __POS_OF__
"1\n\
restart\n";
()
let test_restart_any_tool =
Test.test "restart any tool" @@ fun () ->
let cmd =
Cmd.make (Cmd.info "test_restart") @@
let arg ~docv =
let completion = Arg.Completion.complete_restart in
Arg.Conv.of_conv Arg.string ~docv:"TOOL" ~completion
in
let+ verb = Arg.(value & flag & info ["verbose"])
and+ tool = Arg.(required & pos 0 (some (arg ~docv:"TOOL")) None & info [])
and+ args = Arg.(value & pos_right 0 (arg ~docv:"ARG") [] & info []) in
()
in
let complete = Testing_cmdliner.snap_completion cmd in
complete ["--__complete="] @@ __POS_OF__
"1\n\
group\n\
Options\n\
item\n\
--verbose\n\
\n\
item-end\n\
item\n\
--help\n\
Show this help in format \u{001B}[04mFMT\u{001B}[m. The value \u{001B}[04mFMT\u{001B}[m must be one of \u{001B}[01mauto\u{001B}[m, \u{001B}[01mpager\u{001B}[m, \u{001B}[01mgroff\u{001B}[m\n\
or \u{001B}[01mplain\u{001B}[m. With \u{001B}[01mauto\u{001B}[m, the format is \u{001B}[01mpager\u{001B}[m or \u{001B}[01mplain\u{001B}[m whenever the \u{001B}[01mTERM\u{001B}[m env var\n\
is \u{001B}[01mdumb\u{001B}[m or undefined.\n\
item-end\n";
(* The following two do not restart because -- is missing *)
complete ["--__complete=gi"] @@ __POS_OF__
"1\n";
complete ["git"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Options\n\
item\n\
--verbose\n\
\n\
item-end\n\
item\n\
--help\n\
Show this help in format \u{001B}[04mFMT\u{001B}[m. The value \u{001B}[04mFMT\u{001B}[m must be one of \u{001B}[01mauto\u{001B}[m, \u{001B}[01mpager\u{001B}[m, \u{001B}[01mgroff\u{001B}[m\n\
or \u{001B}[01mplain\u{001B}[m. With \u{001B}[01mauto\u{001B}[m, the format is \u{001B}[01mpager\u{001B}[m or \u{001B}[01mplain\u{001B}[m whenever the \u{001B}[01mTERM\u{001B}[m env var\n\
is \u{001B}[01mdumb\u{001B}[m or undefined.\n\
item-end\n";
(* These must restart *)
complete ["--"; "--__complete=gi"] @@ __POS_OF__
"1\n\
restart\n";
complete ["--"; "git"; "--__complete="] @@ __POS_OF__
"1\n\
restart\n";
()
let test_context =
Test.test "Context sensitive completion from optional argument" @@ fun () ->
let ctx =
Arg.(value & opt (some bool) None & info ["ctx"])
in
let dep =
let complete ctx ~token:_ = match ctx with
| None -> Ok [Arg.Completion.string "ctx-parse-error"]
| Some None -> Ok [Arg.Completion.string "no-context"]
| Some (Some ctx) -> Ok [Arg.Completion.string (Bool.to_string ctx)]
in
let completion = Arg.Completion.make ~context:ctx complete in
Arg.Conv.of_conv Arg.string ~docv:"SPECIAL" ~completion
in
let () = (* test [dep] converter on an option *)
let cmd =
Cmd.make (Cmd.info "test_context") @@
let+ lookup = Arg.(value & opt dep "nothing" & info ["dep"])
and+ ctx in
()
in
let complete = Testing_cmdliner.snap_completion cmd in
complete ["--dep"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
no-context\n\
\n\
item-end\n";
complete ["--ctx=hey"; "--dep"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
ctx-parse-error\n\
\n\
item-end\n";
complete ["--ctx=true"; "--dep"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
true\n\
\n\
item-end\n";
complete ["--dep"; "--__complete="; "--ctx=true"] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
true\n\
\n\
item-end\n";
in
let () =
let cmd =
Cmd.make (Cmd.info "test_context") @@
let+ lookup = Arg.(value & pos 0 dep "nothing" & info [])
and+ ctx in
()
in
let complete = Testing_cmdliner.snap_completion cmd in
complete ["--__complete=a"] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
no-context\n\
\n\
item-end\n";
complete ["--ctx=hey"; "--__complete=a"] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
ctx-parse-error\n\
\n\
item-end\n";
complete ["--ctx=true"; "--__complete=a"] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
true\n\
\n\
item-end\n";
complete ["--__complete=a"; "--ctx=true"] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
true\n\
\n\
item-end\n";
in
()
let test_context =
Test.test "Context sensitive completion from positional argument" @@ fun () ->
let ctx0 = Arg.(value & pos 0 (some bool) None & info []) in
let dep =
let complete ctx ~token:_ = match ctx with
| None -> Ok [Arg.Completion.string "ctx-parse-error"]
| Some None -> Ok [Arg.Completion.string "no-context"]
| Some (Some ctx) -> Ok [Arg.Completion.string (Bool.to_string ctx)]
in
let completion = Arg.Completion.make ~context:ctx0 complete in
Arg.Conv.of_conv Arg.string ~docv:"SPECIAL" ~completion
in
let () = (* test [dep] converter on an option *)
let cmd =
Cmd.make (Cmd.info "test_context") @@
let+ lookup = Arg.(value & opt dep "nothing" & info ["dep"])
and+ ctx0 in
()
in
let complete = Testing_cmdliner.snap_completion cmd in
complete ["--dep"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
no-context\n\
\n\
item-end\n";
complete ["bla"; "--dep"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
ctx-parse-error\n\
\n\
item-end\n";
complete ["true"; "--dep"; "--__complete="] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
true\n\
\n\
item-end\n";
complete ["--dep"; "--__complete="; "true"] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
true\n\
\n\
item-end\n";
in
let () =
let cmd =
Cmd.make (Cmd.info "test_context") @@
let+ lookup = Arg.(value & pos 1 dep "nothing" & info [])
and+ ctx0 in
()
in
let complete = Testing_cmdliner.snap_completion cmd in
complete ["hey"; "--__complete=a"] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
ctx-parse-error\n\
\n\
item-end\n";
complete ["true"; "--__complete=a"] @@ __POS_OF__
"1\n\
group\n\
Values\n\
item\n\
true\n\
\n\
item-end\n";
in
()
let main () =
let doc = "Test completion" in
Test.main ~doc @@ fun () -> Test.autorun ()
let () = if !Sys.interactive then () else exit (main ())

63
unikernel/duniverse/cmdliner/test/test_deprecation.ml Normal file
View file

@ -0,0 +1,63 @@
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
open B0_std
open B0_testing
open Cmdliner
open Cmdliner.Term.Syntax
let cmd = Testing_cmdliner.sample_group_cmd
let warning ?env = Testing_cmdliner.snap_parse_warnings ?env cmd
let test_env = function "BACTRIAN" -> Some "true" | var -> Sys.getenv_opt var
let deprecated_command =
Test.test "Deprecated command" @@ fun () ->
warning ["camels"] @@ __POS_OF__
"test_group: \u{001B}[33mdeprecated\u{001B}[m command \u{001B}[01mcamels\u{001B}[m: Use \u{001B}[01mmammals\u{001B}[m instead.\n";
()
let deprecated_arg =
Test.test "Deprecated option argument" @@ fun () ->
warning ["camels"; "-b"] @@ __POS_OF__
"test_group: \u{001B}[33mdeprecated\u{001B}[m command \u{001B}[01mcamels\u{001B}[m: Use \u{001B}[01mmammals\u{001B}[m instead.\n\
\ \u{001B}[33mdeprecated\u{001B}[m option \u{001B}[01m-b\u{001B}[m: Use nothing instead of \u{001B}[01mBACTRIAN\u{001B}[m, \u{001B}[01mHA!\u{001B}[m.\n";
warning ["camels"; "--bactrian"] @@ __POS_OF__
"test_group: \u{001B}[33mdeprecated\u{001B}[m command \u{001B}[01mcamels\u{001B}[m: Use \u{001B}[01mmammals\u{001B}[m instead.\n\
\ \u{001B}[33mdeprecated\u{001B}[m option \u{001B}[01m--bactrian\u{001B}[m: Use nothing instead of \u{001B}[01mBACTRIAN\u{001B}[m,\n\
\ \u{001B}[01mHA!\u{001B}[m.\n";
()
let deprecated_pos =
Test.test "Deprecated positional argument" @@ fun () ->
warning ["camels"; "bla"] @@ __POS_OF__
"test_group: \u{001B}[33mdeprecated\u{001B}[m command \u{001B}[01mcamels\u{001B}[m: Use \u{001B}[01mmammals\u{001B}[m instead.\n\
\ \u{001B}[33mdeprecated\u{001B}[m argument \u{001B}[01mbla\u{001B}[m: Herds \u{001B}[04mHERD\u{001B}[m are ignored.\n";
()
let deprecated_env =
Test.test "Deprecated env variable" @@ fun () ->
warning ~env:test_env ["camels"] @@ __POS_OF__
"test_group: \u{001B}[33mdeprecated\u{001B}[m command \u{001B}[01mcamels\u{001B}[m: Use \u{001B}[01mmammals\u{001B}[m instead.\n\
\ \u{001B}[33mdeprecated\u{001B}[m environment variable \u{001B}[01mBACTRIAN\u{001B}[m: Use nothing instead of\n\
\ \u{001B}[01mBACTRIAN\u{001B}[m, \u{001B}[01mHA!\u{001B}[m.\n";
warning ~env:test_env ["camels"; "-b"] (* takes over env *) @@ __POS_OF__
"test_group: \u{001B}[33mdeprecated\u{001B}[m command \u{001B}[01mcamels\u{001B}[m: Use \u{001B}[01mmammals\u{001B}[m instead.\n\
\ \u{001B}[33mdeprecated\u{001B}[m option \u{001B}[01m-b\u{001B}[m: Use nothing instead of \u{001B}[01mBACTRIAN\u{001B}[m, \u{001B}[01mHA!\u{001B}[m.\n";
()
let deprecated_combined =
Test.test "Deprecation combined" @@ fun () ->
warning ~env:test_env ["camels"; "bla"; ] @@ __POS_OF__
"test_group: \u{001B}[33mdeprecated\u{001B}[m command \u{001B}[01mcamels\u{001B}[m: Use \u{001B}[01mmammals\u{001B}[m instead.\n\
\ \u{001B}[33mdeprecated\u{001B}[m argument \u{001B}[01mbla\u{001B}[m: Herds \u{001B}[04mHERD\u{001B}[m are ignored.\n\
\ \u{001B}[33mdeprecated\u{001B}[m environment variable \u{001B}[01mBACTRIAN\u{001B}[m: Use nothing instead of\n\
\ \u{001B}[01mBACTRIAN\u{001B}[m, \u{001B}[01mHA!\u{001B}[m.\n";
()
let main () =
let doc = "Test deprecation messages" in
Test.main ~doc @@ fun () -> Test.autorun ()
let () = if !Sys.interactive then () else exit (main ())

68
unikernel/duniverse/cmdliner/test/test_legacy_prefix.ml Normal file
View file

@ -0,0 +1,68 @@
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
open B0_std
open B0_testing
open Cmdliner
open Cmdliner.Term.Syntax
let env ~legacy_prefixes:b =
let b = string_of_bool b in
function
| "CMDLINER_LEGACY_PREFIXES" -> Some b
| var -> Sys.getenv_opt var
let legacy = env ~legacy_prefixes:true
let nolegacy = env ~legacy_prefixes:false
let cmd = Testing_cmdliner.sample_group_cmd
let parse_legacy = Testing_cmdliner.snap_parse ~env:legacy Test.T.unit cmd
let error_nolegacy err = Testing_cmdliner.snap_eval_error ~env:nolegacy err cmd
(* Note, we don't test Arg.conv since we cannot control it through eval's
env variable. *)
(* The tests have the following structure:
let test =
(* A few snapshots of valid cli parses *)
parse …
(* A few snapshots of invalid cli parses *)
error … *)
let test_cmd =
Test.test "command names" @@ fun () ->
parse_legacy ["bir"] @@ __POS_OF__ ();
parse_legacy ["bir"; "fly"] @@ __POS_OF__ ();
parse_legacy ["mamma"] @@ __POS_OF__ ();
(**)
error_nolegacy `Term ["bir"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_group\u{001B}[m [\u{001B}[01m--help\u{001B}[m] \u{001B}[04mCOMMAND\u{001B}[m …\n\
test_group: \u{001B}[31munknown\u{001B}[m command \u{001B}[01mbir\u{001B}[m. Did you mean \u{001B}[01mbirds\u{001B}[m?\n";
error_nolegacy `Term ["birds"; "fl"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_group birds\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[04mCOMMAND\u{001B}[m] …\n\
test_group: \u{001B}[31munknown\u{001B}[m command \u{001B}[01mfl\u{001B}[m. Did you mean \u{001B}[01mfly\u{001B}[m?\n";
error_nolegacy `Term ["mam"] @@ __POS_OF__ "Usage: \u{001B}[01mtest_group\u{001B}[m [\u{001B}[01m--help\u{001B}[m] \u{001B}[04mCOMMAND\u{001B}[m …\n\
test_group: \u{001B}[31munknown\u{001B}[m command \u{001B}[01mmam\u{001B}[m. Must be one of \u{001B}[01mbirds\u{001B}[m, \u{001B}[01mcamels\u{001B}[m, \u{001B}[01mfishs\u{001B}[m, \u{001B}[01mlookup\u{001B}[m\n\
\ or \u{001B}[01mmammals\u{001B}[m\n";
()
let test_cmd =
Test.test "option names" @@ fun () ->
parse_legacy ["birds"; "fly"; "--sp"; "3"] @@ __POS_OF__ ();
(**)
error_nolegacy `Term ["birds"; "fly"; "--sp"; ] @@ __POS_OF__
"Usage: \u{001B}[01mtest_group birds fly\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[01m--speed\u{001B}[m=\u{001B}[04mSPEED\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]… [\u{001B}[04mBIRD\u{001B}[m]\n\
test_group: \u{001B}[31munknown\u{001B}[m option \u{001B}[01m--sp\u{001B}[m\n";
error_nolegacy `Term ["birds"; "fly"; "--spe"; ] @@ __POS_OF__
"Usage: \u{001B}[01mtest_group birds fly\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[01m--speed\u{001B}[m=\u{001B}[04mSPEED\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]… [\u{001B}[04mBIRD\u{001B}[m]\n\
test_group: \u{001B}[31munknown\u{001B}[m option \u{001B}[01m--spe\u{001B}[m. Did you mean \u{001B}[01m--speed\u{001B}[m?\n";
()
let main () =
let doc = "Test CMDLINER_LEGACY_PREFIXES behaviour" in
Test.main ~doc @@ fun () -> Test.autorun ()
let () = if !Sys.interactive then () else exit (main ())

406
unikernel/duniverse/cmdliner/test/test_man.ml Normal file
View file

@ -0,0 +1,406 @@
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
open B0_std
open B0_testing
open Cmdliner
open Cmdliner.Term.Syntax
let hey =
let doc = "Equivalent to set $(opt)." in
let env = Cmd.Env.info "TEST_ENV" ~doc in
let doc = "Set hey." in
Arg.(value & flag & info ["hey"; "y"] ~env ~doc)
let repodir =
let doc = "See option $(opt)." in
let env = Cmd.Env.info "TEST_REPODDIR" ~doc in
let doc = "Run the program in repository directory $(docv)." in
Arg.(value & opt file Filename.current_dir_name & info ["repodir"] ~env
~docv:"DIR" ~doc)
let id =
let doc = "See option $(opt)." in
let env = Cmd.Env.info "TEST_ID" ~doc in
let doc = "Whatever $(docv) bla $(env) and $(opt)." in
Arg.(value & opt int ~vopt:10 0 & info ["id"; "i"] ~env ~docv:"ID)" ~doc)
let miaouw =
let doc = "See option $(opt). These are term names $(tool) $(cmd.name)" in
let docs = "MIAOUW SECTION (non-standard unpositioned do not do this)" in
let env = Cmd.Env.info "TEST_MIAOUW" ~doc ~docs in
let doc = "Whatever this is the doc var $(docv) this is the env var $(env) \
this is the opt $(opt) and this is $(i,italic) and this is
$(b,bold) and this $(b,\\$(opt\\)) is \\$(opt) in bold and this
\\$ is a dollar. $(tool) is the main command name, $(cmd.name) \
is the subcommand name and $(cmd) the command invocation."
in
Arg.(value & opt string "miaouw" & info ["m";] ~env ~docv:"MIAOUW" ~doc)
let test hey repodir id miaouw =
Format.printf "hey: %B@.repodir: %s@.id: %d@.miaouw: %s@."
hey repodir id miaouw
let man_test_t = Term.(const test $ hey $ repodir $ id $ miaouw)
let info =
let doc = "UTF-8 test: \u{1F42B} íöüóőúűéáăîâșț ÍÜÓŐÚŰÉÁĂÎÂȘȚ 雙峰駱駝" in
let envs = [ Cmd.Env.info "TEST_IT" ~doc:"This is $(env) for $(cmd.name)" ] in
let exits = (Cmd.Exit.info ~doc:"This is a $(status) for $(cmd.name)" 1 ::
Cmd.Exit.info ~doc:"Ranges from $(status) to $(status_max)"
~max:10 2 ::
Cmd.Exit.defaults)
in
let man = [
`S "THIS IS A SECTION FOR $(tool)";
`P "$(cmd.name) subst at begin and end $(tool)";
`P "$(i,italic) and $(b,bold)";
`P "\\$ escaped \\$\\$ escaped \\$";
`P "This does not fail \\$(a)";
`P ". this is a paragraph starting with a dot.";
`P "' this is a paragraph starting with a quote.";
`P "This: \\\\(rs is a backslash for groff and you should not see a \\\\";
`P "This: \\\\N'46' is a quote for groff and you should not see a '";
`P "This: \\\\\" is a groff comment and it should not be one.";
`P "This is a non preformatted paragraph, filling will occur. This will
be properly layout on 80 columns.";
`Pre "This is a preformatted paragraph for $(tool) no filling will \
occur do the $(i,ASCII) art $(b,here) this will overflow on 80 \
columns \n\
01234556789\
01234556789\
01234556789\
01234556789\
01234556789\
01234556789\
01234556789\
01234556789\n\n\
... Should not break\n\
a... Should not break\n\
+---+\n\
| /|\n\
| / | ----> Let's swim to the moon.\n\
|/ |\n\
+---+";
`P "These are escapes escaped \\$ \\( \\) \\\\";
`P "() does not need to be escaped outside directives.";
`Blocks [
`P "The following to paragraphs are spliced in.";
`P "This dollar needs escape \\$(var) this one as well $(b,\\$(bla\\))";
`P "This is another paragraph \\$(bla) $(i,\\$(bla\\)) $(b,\\$\\(bla\\))";
];
`Noblank;
`Pre "This is another preformatted paragraph.\n\
There should be no blanks before and after it.";
`Noblank;
`P "Hey ho";
`I ("label", "item label");
`I ("lebal", "item lebal");
`P "The last paragraph";
`S Manpage.s_bugs;
`P "Email bug reports to <hehey at example.org>.";]
in
let man_xrefs = [`Page ("ascii", 7); `Main; `Tool "grep";] in
Cmd.info "man_test" ~version:"v2.0.0+dune" ~doc ~envs ~exits ~man ~man_xrefs
let cmd = Cmd.make info man_test_t
let test_plain =
Test.test "plain text manpage" @@ fun () ->
Testing_cmdliner.snap_man cmd @@ __POS_OF__
{|NAME
man_test - UTF-8 test: 🐫 íöüóőúűéáăîâșț
ÍÜÓŐÚŰÉÁĂÎÂȘȚ 雙峰駱駝
SYNOPSIS
man_test [OPTION]…
THIS IS A SECTION FOR man_test
man_test subst at begin and end man_test
italic and bold
$ escaped $$ escaped $
This does not fail $(a)
. this is a paragraph starting with a dot.
' this is a paragraph starting with a quote.
This: \(rs is a backslash for groff and you should not see a \
This: \N'46' is a quote for groff and you should not see a '
This: \" is a groff comment and it should not be one.
This is a non preformatted paragraph, filling will occur. This will be
properly layout on 80 columns.
This is a preformatted paragraph for man_test no filling will occur do the ASCII art here this will overflow on 80 columns
0123455678901234556789012345567890123455678901234556789012345567890123455678901234556789
... Should not break
a... Should not break
+---+
| /|
| / | ----> Let's swim to the moon.
|/ |
+---+
These are escapes escaped $ ( ) \
() does not need to be escaped outside directives.
The following to paragraphs are spliced in.
This dollar needs escape $(var) this one as well $(bla)
This is another paragraph $(bla) $(bla) $(bla)
This is another preformatted paragraph.
There should be no blanks before and after it.
Hey ho
label
item label
lebal
item lebal
The last paragraph
MIAOUW SECTION (non-standard unpositioned do not do this)
TEST_MIAOUW
See option -m. These are term names man_test man_test
OPTIONS
-i [ID)], --id[=ID)] (default=10) (absent=0 or TEST_ID env)
Whatever ID) bla TEST_ID and --id.
-m MIAOUW (absent=miaouw or TEST_MIAOUW env)
Whatever this is the doc var MIAOUW this is the env var
TEST_MIAOUW this is the opt -m and this is italic and this is bold
and this $(opt) is $(opt) in bold and this $ is a dollar. man_test
is the main command name, man_test is the subcommand name and
man_test the command invocation.
--repodir=DIR (absent=. or TEST_REPODDIR env)
Run the program in repository directory DIR.
-y, --hey (absent TEST_ENV env)
Set hey.
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
--version
Show version information.
EXIT STATUS
man_test exits with:
0 on success.
1 This is a 1 for man_test
2-10
Ranges from 2 to 10
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
125 on unexpected internal errors (bugs).
ENVIRONMENT
These environment variables affect the execution of man_test:
TEST_ENV
Equivalent to set --hey.
TEST_ID
See option --id.
TEST_IT
This is TEST_IT for man_test
TEST_REPODDIR
See option --repodir.
BUGS
Email bug reports to <hehey at example.org>.
SEE ALSO|}
let test_groff =
Test.test "groff manpage" @@ fun () ->
Testing_cmdliner.snap_man ~args:["--help=groff"] cmd @@ __POS_OF__
{|.\" Pipe this output to groff -m man -K utf8 -T utf8 | less -R
.\"
.mso an.tmac
.TH "MAN_TEST" 1 "" "Man_test v2.0.0+dune" "Man_test Manual"
.\" Disable hyphenation and ragged-right
.nh
.ad l
.SH NAME
.P
man_test \N'45' UTF\N'45'8 test: 🐫 íöüóőúűéáăîâșț ÍÜÓŐÚŰÉÁĂÎÂȘȚ 雙峰駱駝
.SH SYNOPSIS
.P
\fBman_test\fR [\fIOPTION\fR]…
.SH THIS IS A SECTION FOR \fBman_test\fR
.P
\fBman_test\fR subst at begin and end \fBman_test\fR
.P
\fIitalic\fR and \fBbold\fR
.P
$ escaped $$ escaped $
.P
This does not fail $(a)
.P
\N'46' this is a paragraph starting with a dot\N'46'
.P
\N'39' this is a paragraph starting with a quote\N'46'
.P
This: \N'92'(rs is a backslash for groff and you should not see a \N'92'
.P
This: \N'92'N\N'39'46\N'39' is a quote for groff and you should not see a \N'39'
.P
This: \N'92'" is a groff comment and it should not be one\N'46'
.P
This is a non preformatted paragraph, filling will occur\N'46' This will be properly layout on 80 columns\N'46'
.P
.nf
This is a preformatted paragraph for \fBman_test\fR no filling will occur do the \fIASCII\fR art \fBhere\fR this will overflow on 80 columns
0123455678901234556789012345567890123455678901234556789012345567890123455678901234556789
\N'46'\N'46'\N'46' Should not break
a\N'46'\N'46'\N'46' Should not break
+\N'45'\N'45'\N'45'+
| /|
| / | \N'45'\N'45'\N'45'\N'45'> Let\N'39's swim to the moon\N'46'
|/ |
+\N'45'\N'45'\N'45'+
.fi
.P
These are escapes escaped $ ( ) \N'92'
.P
() does not need to be escaped outside directives\N'46'
.P
The following to paragraphs are spliced in\N'46'
.P
This dollar needs escape $(var) this one as well \fB$(bla)\fR
.P
This is another paragraph $(bla) \fI$(bla)\fR \fB$(bla)\fR
.sp -1
.P
.nf
This is another preformatted paragraph\N'46'
There should be no blanks before and after it\N'46'
.fi
.sp -1
.P
Hey ho
.TP 4
label
item label
.TP 4
lebal
item lebal
.P
The last paragraph
.SH MIAOUW SECTION (non\N'45'standard unpositioned do not do this)
.TP 4
\fBTEST_MIAOUW\fR
See option \fB\N'45'm\fR\N'46' These are term names \fBman_test\fR \fBman_test\fR
.SH OPTIONS
.TP 4
\fB\N'45'i\fR [\fIID)\fR], \fB\N'45'\N'45'id\fR[=\fIID)\fR] (default=\fB10\fR) (absent=\fB0\fR or \fBTEST_ID\fR env)
Whatever \fIID)\fR bla \fBTEST_ID\fR and \fB\N'45'\N'45'id\fR\N'46'
.TP 4
\fB\N'45'm\fR \fIMIAOUW\fR (absent=\fBmiaouw\fR or \fBTEST_MIAOUW\fR env)
Whatever this is the doc var \fIMIAOUW\fR this is the env var \fBTEST_MIAOUW\fR this is the opt \fB\N'45'm\fR and this is \fIitalic\fR and this is \fBbold\fR and this \fB$(opt)\fR is $(opt) in bold and this $ is a dollar\N'46' \fBman_test\fR is the main command name, \fBman_test\fR is the subcommand name and \fBman_test\fR the command invocation\N'46'
.TP 4
\fB\N'45'\N'45'repodir\fR=\fIDIR\fR (absent=\fB\N'46'\fR or \fBTEST_REPODDIR\fR env)
Run the program in repository directory \fIDIR\fR\N'46'
.TP 4
\fB\N'45'y\fR, \fB\N'45'\N'45'hey\fR (absent \fBTEST_ENV\fR env)
Set hey\N'46'
.SH COMMON OPTIONS
.TP 4
\fB\N'45'\N'45'help\fR[=\fIFMT\fR] (default=\fBauto\fR)
Show this help in format \fIFMT\fR\N'46' The value \fIFMT\fR must be one of \fBauto\fR, \fBpager\fR, \fBgroff\fR or \fBplain\fR\N'46' With \fBauto\fR, the format is \fBpager\fR or \fBplain\fR whenever the \fBTERM\fR env var is \fBdumb\fR or undefined\N'46'
.TP 4
\fB\N'45'\N'45'version\fR
Show version information\N'46'
.SH EXIT STATUS
.P
\fBman_test\fR exits with:
.TP 4
0
on success\N'46'
.TP 4
1
This is a 1 for \fBman_test\fR
.TP 4
2\N'45'10
Ranges from 2 to 10
.TP 4
123
on indiscriminate errors reported on standard error\N'46'
.TP 4
124
on command line parsing errors\N'46'
.TP 4
125
on unexpected internal errors (bugs)\N'46'
.SH ENVIRONMENT
.P
These environment variables affect the execution of \fBman_test\fR:
.TP 4
\fBTEST_ENV\fR
Equivalent to set \fB\N'45'\N'45'hey\fR\N'46'
.TP 4
\fBTEST_ID\fR
See option \fB\N'45'\N'45'id\fR\N'46'
.TP 4
\fBTEST_IT\fR
This is \fBTEST_IT\fR for \fBman_test\fR
.TP 4
\fBTEST_REPODDIR\fR
See option \fB\N'45'\N'45'repodir\fR\N'46'
.SH BUGS
.P
Email bug reports to <hehey at example\N'46'org>\N'46'
.SH SEE ALSO
.P
ascii(7), grep(1)|}
let main () =
let doc = "Test manpage specifications" in
let test_help =
let doc = "Test manpage interactively as if --help[$(docv)] is invoked" in
let help_fmts =
["auto", "=auto"; "pager", "=pager"; "groff", "=groff";
"plain", "=plain"; "", ""]
in
let help_enum = Cmdliner.Arg.enum help_fmts and docv = "FMT" in
Arg.(value & opt ~vopt:(Some "") (some help_enum) None &
info ["test-help"] ~docv ~doc)
in
Test.main' test_help ~doc @@ function
| None ->
Test.log "Invoke with %a[=FMT] to test %a[=FMT] interactively"
Fmt.code "--test-help" Fmt.code "--help";
Test.autorun ()
| Some fmt ->
Test.set_main_exit @@ fun () ->
let argv = Array.of_list (Cmd.name cmd :: ["--help" ^ fmt ]) in
Cmd.eval ~argv (Cmd.v info man_test_t)
let () = if !Sys.interactive then () else exit (main ())

159
unikernel/duniverse/cmdliner/test/test_term.ml Normal file
View file

@ -0,0 +1,159 @@
(*---------------------------------------------------------------------------
Copyright (c) 2025 The cmdliner programmers. All rights reserved.
SPDX-License-Identifier: ISC
---------------------------------------------------------------------------*)
open B0_std
open B0_testing
open Cmdliner
open Cmdliner.Term.Syntax
(* The tests have the following structure:
let test =
let cmd = … (* A command definition *) in
(* A few snapshots of valid cli parses *)
parse …
(* A few snapshots of invalid cli parses *)
error …
(* A snapshot of a plain text version of the manual *)
Testing_cmdliner.snap_man … *)
let test_with_used_args =
Test.test "Term.with_used_args" @@ fun () ->
let cmd =
Cmd.make (Cmd.info "test_with_used_args" ~doc:"Test cli arg capture") @@
let args =
let+ a = Arg.(value & flag & info ["a"; "aaa"])
and+ b = Arg.(value & opt (some string) None & info ["b"; "bbb"])
and+ c = Arg.(value & pos_all string [] & info []) in
(a, b, c)
in
let+ parse, args = Term.with_used_args args in
args, parse
in
let t = Test.T.(t2 (list string) (t3 bool (option string) (list string))) in
let parse = Testing_cmdliner.snap_parse t cmd in
let error err = Testing_cmdliner.snap_eval_error err cmd in
parse [] @@ __POS_OF__
([], (false, None, []));
(* Note some of these are bugs, see issue #204 *)
parse ["--"] @@ __POS_OF__
([], (false, None, []));
parse ["hoho"; "-a"; "-bmsg"] @@ __POS_OF__
(["-a"; "-b"; "msg"; "hoho"], (true, Some "msg", ["hoho"]));
parse ["hoho"; "-a"; "-bmsg"; "hihi"] @@ __POS_OF__
(["-a"; "-b"; "msg"; "hoho"; "hihi"], (true, Some "msg", ["hoho"; "hihi"]));
parse ["--"; "hoho"; "-a"; "-bbla"; "hihi"] @@ __POS_OF__
(["hoho"; "-a"; "-bbla"; "hihi"],
(false, None, ["hoho"; "-a"; "-bbla"; "hihi"]));
parse ["hoho"; "-a"; "--bbb=msg"; "hihi"] @@ __POS_OF__
(["-a"; "--bbb"; "msg"; "hoho"; "hihi"],
(true, Some "msg", ["hoho"; "hihi"]));
(**)
error `Term ["--opt"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_with_used_args\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[01m--aaa\u{001B}[m] [\u{001B}[01m--bbb\u{001B}[m=\u{001B}[04mVAL\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]… [\u{001B}[04mARG\u{001B}[m]…\n\
test_with_used_args: \u{001B}[31munknown\u{001B}[m option \u{001B}[01m--opt\u{001B}[m\n";
(**)
Testing_cmdliner.snap_man cmd @@ __POS_OF__
{|NAME
test_with_used_args - Test cli arg capture
SYNOPSIS
test_with_used_args [--aaa] [--bbb=VAL] [OPTION]… [ARG]…
OPTIONS
-a, --aaa
-b VAL, --bbb=VAL
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
EXIT STATUS
test_with_used_args exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
|};
()
let term_duplication =
Test.test "Term.app duplicates" @@ fun () ->
let cmd =
Cmd.make (Cmd.info "test_term_dups" ~doc:"Test multiple term usage") @@
let+ p =
let doc = "First pos argument should show up only once in the docs" in
Arg.(value & pos 0 string "popopo" & info [] ~doc ~docv:"POS")
and+ o =
let doc = "This should show up only once in the docs" in
Arg.(value & flag & info ["f"; "flag"] ~doc)
in
(p, p, o, o)
in
let t = Test.T.(t4 string string bool bool) in
let parse = Testing_cmdliner.snap_parse t cmd in
let error err = Testing_cmdliner.snap_eval_error err cmd in
parse [] @@ __POS_OF__ ("popopo", "popopo", false, false);
parse ["0"] @@ __POS_OF__ ("0", "0", false, false);
parse ["0"; "-f"] @@ __POS_OF__ ("0", "0", true, true);
(**)
error `Term ["0"; "1"] @@ __POS_OF__
"Usage: \u{001B}[01mtest_term_dups\u{001B}[m [\u{001B}[01m--help\u{001B}[m] [\u{001B}[01m--flag\u{001B}[m] [\u{001B}[04mOPTION\u{001B}[m]… [\u{001B}[04mPOS\u{001B}[m]\n\
test_term_dups: \u{001B}[31mtoo many arguments\u{001B}[m, don't know what to do with \u{001B}[01m1\u{001B}[m\n";
(**)
Testing_cmdliner.snap_man cmd @@ __POS_OF__
{|NAME
test_term_dups - Test multiple term usage
SYNOPSIS
test_term_dups [--flag] [OPTION]… [POS]
ARGUMENTS
POS (absent=popopo)
First pos argument should show up only once in the docs
OPTIONS
-f, --flag
This should show up only once in the docs
COMMON OPTIONS
--help[=FMT] (default=auto)
Show this help in format FMT. The value FMT must be one of auto,
pager, groff or plain. With auto, the format is pager or plain
whenever the TERM env var is dumb or undefined.
EXIT STATUS
test_term_dups exits with:
0 on success.
123 on indiscriminate errors reported on standard error.
124 on command line parsing errors.
|};
()
let test_env =
Test.test "Term.env" @@ fun () ->
let env = function "HEYHO" -> Some "Let's go" | _ -> None in
let cmd =
Cmd.make (Cmd.info "test_env" ~doc:"Test Term.env") @@
let+ env = Term.env in
Test.(option T.string) (env "HEYHO") (Some "Let's go")
in
Testing_cmdliner.test_eval_result ~env Test.T.unit cmd [] (Ok (`Ok ()));
()
let main () =
let doc = "Test term specifications" in
Test.main ~doc @@ fun () -> Test.autorun ()
let () = if !Sys.interactive then () else exit (main ())

199
unikernel/duniverse/cmdliner/test/testing_cmdliner.ml Normal file
View file

@ -0,0 +1,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]