From ccb3efc55e082d21d8e643454df3a9937fde4783 Mon Sep 17 00:00:00 2001 From: Mehdi Dogguy Date: Fri, 11 May 2018 15:30:44 +0200 Subject: Import cmdliner_1.0.2-1.debian.tar.xz [dgit import tarball cmdliner 1.0.2-1 cmdliner_1.0.2-1.debian.tar.xz] --- changelog | 60 ++++++++++++++++++++++++++++++++++++++++ compat | 1 + control | 39 ++++++++++++++++++++++++++ copyright | 23 +++++++++++++++ examples | 1 + gbp.conf | 2 ++ libcmdliner-ocaml-dev.docs | 1 + libcmdliner-ocaml-dev.install.in | 1 + libcmdliner-ocaml-dev.ocamldoc | 1 + patches/install-x.patch | 34 +++++++++++++++++++++++ patches/series | 1 + rules | 19 +++++++++++++ source/format | 1 + watch | 2 ++ 14 files changed, 186 insertions(+) create mode 100644 changelog create mode 100644 compat create mode 100644 control create mode 100644 copyright create mode 100644 examples create mode 100644 gbp.conf create mode 100644 libcmdliner-ocaml-dev.docs create mode 100644 libcmdliner-ocaml-dev.install.in create mode 100644 libcmdliner-ocaml-dev.ocamldoc create mode 100644 patches/install-x.patch create mode 100644 patches/series create mode 100755 rules create mode 100644 source/format create mode 100644 watch diff --git a/changelog b/changelog new file mode 100644 index 0000000..dd4f7c1 --- /dev/null +++ b/changelog @@ -0,0 +1,60 @@ +cmdliner (1.0.2-1) unstable; urgency=medium + + [ Hendrik Tews ] + * New upstream version 1.0.2 + * compat level 10, standards version 4.0.0 + * add build dependency libresult-ocaml-dev + * update VCS fields + * add myself to uploaders + * updated copyright + * update rules: remove most of the overrides, build sequential because + ocamlbuild would otherwise fail + * remove .doc-base file: there is no documentation any more + * fix .docs file + * add patch install-x for removing x-permission in make install + * add README.Debian to point to the online documentation + * generate documentation with dh_ocamldoc, the command line switches in + libcmdliner-ocaml-dev.ocamldoc have been copied from a run of ``topkg doc'' + * remove README.Debian again + + [ Mehdi Dogguy ] + * Update Vcs-* fields to target Salsa + + -- Mehdi Dogguy Fri, 11 May 2018 15:30:44 +0200 + +cmdliner (0.9.8-2) unstable; urgency=medium + + * Team upload + * Add ocamlbuild to Build-Depends + + -- Stéphane Glondu Sat, 15 Jul 2017 16:06:19 +0200 + +cmdliner (0.9.8-1) unstable; urgency=medium + + * New upstream release + + -- Mehdi Dogguy Mon, 18 Jan 2016 00:35:03 +0100 + +cmdliner (0.9.7-1) unstable; urgency=medium + + * Team upload + * New upstream release + * Update debian/watch + * Update Vcs-* + * Bump Standards-Version to 3.9.6 + + -- Stéphane Glondu Tue, 07 Jul 2015 11:22:00 +0200 + +cmdliner (0.9.4-1) unstable; urgency=medium + + * New upstream release. + * Use a new build system in order to avoid unnecessary new build + dependencies. + + -- Mehdi Dogguy Thu, 27 Mar 2014 21:50:58 +0100 + +cmdliner (0.9.3-1) unstable; urgency=low + + * Initial upload (Closes: #641986) + + -- Mehdi Dogguy Sun, 06 Jan 2013 10:50:00 +0200 diff --git a/compat b/compat new file mode 100644 index 0000000..f599e28 --- /dev/null +++ b/compat @@ -0,0 +1 @@ +10 diff --git a/control b/control new file mode 100644 index 0000000..2dd0918 --- /dev/null +++ b/control @@ -0,0 +1,39 @@ +Source: cmdliner +Section: ocaml +Priority: optional +Maintainer: Debian OCaml Maintainers +Uploaders: + Mehdi Dogguy , + Hendrik Tews +Build-Depends: + debhelper (>= 10.3), + ocaml-nox, + ocaml-findlib (>= 1.2.4), + ocamlbuild, + dh-ocaml (>= 0.9), + libresult-ocaml-dev +Standards-Version: 4.0.0 +Homepage: http://erratique.ch/software/cmdliner +Vcs-Git: https://salsa.debian.org/ocaml-team/cmdliner.git +Vcs-Browser: https://salsa.debian.org/ocaml-team/cmdliner + +Package: libcmdliner-ocaml-dev +Architecture: any +Depends: + ${ocaml:Depends}, + ${shlibs:Depends}, + ${misc:Depends} +Suggests: + ocaml-findlib +Provides: + ${ocaml:Provides} +Description: declarative definition of command line interfaces + 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 syntax errors, help messages and + UNIX man page generation. It supports programs with single or + multiple commands (like darcs or git) and respects most of the POSIX + and GNU conventions. + . + This package contains the development modules you need to use Cmdliner + in your programs. diff --git a/copyright b/copyright new file mode 100644 index 0000000..11d1db1 --- /dev/null +++ b/copyright @@ -0,0 +1,23 @@ +Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Source: http://erratique.ch/logiciel/cmdliner + +Files: * +Copyright: (c) 2011 Daniel C. Bünzli +License: ISC + 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. + +Files: debian/* +Copyright: © 2013 Mehdi Dogguy +License: GPL-2 + The Debian packaging is licensed under the GPL, see + `/usr/share/common-licenses/GPL-2'. diff --git a/examples b/examples new file mode 100644 index 0000000..ab1cfb4 --- /dev/null +++ b/examples @@ -0,0 +1 @@ +test/* diff --git a/gbp.conf b/gbp.conf new file mode 100644 index 0000000..cec628c --- /dev/null +++ b/gbp.conf @@ -0,0 +1,2 @@ +[DEFAULT] +pristine-tar = True diff --git a/libcmdliner-ocaml-dev.docs b/libcmdliner-ocaml-dev.docs new file mode 100644 index 0000000..b43bf86 --- /dev/null +++ b/libcmdliner-ocaml-dev.docs @@ -0,0 +1 @@ +README.md diff --git a/libcmdliner-ocaml-dev.install.in b/libcmdliner-ocaml-dev.install.in new file mode 100644 index 0000000..73752c9 --- /dev/null +++ b/libcmdliner-ocaml-dev.install.in @@ -0,0 +1 @@ +usr diff --git a/libcmdliner-ocaml-dev.ocamldoc b/libcmdliner-ocaml-dev.ocamldoc new file mode 100644 index 0000000..cdd34fb --- /dev/null +++ b/libcmdliner-ocaml-dev.ocamldoc @@ -0,0 +1 @@ +-colorize-code -charset utf-8 -package bytes -package result diff --git a/patches/install-x.patch b/patches/install-x.patch new file mode 100644 index 0000000..fca70df --- /dev/null +++ b/patches/install-x.patch @@ -0,0 +1,34 @@ +Description: install without adding execute permissions +Author: Hendrik Tews +--- a/Makefile ++++ b/Makefile +@@ -35,7 +35,7 @@ + + install-doc: + $(INSTALL) -d $(DOCDIR) +- $(INSTALL) CHANGES.md LICENSE.md README.md $(DOCDIR) ++ $(INSTALL) -m 644 CHANGES.md LICENSE.md README.md $(DOCDIR) + + clean: + $(OCAMLBUILD) -clean +@@ -53,16 +53,16 @@ + $(INSTALL) -d $(LIBDIR) + + install-common: create-libdir +- $(INSTALL) pkg/META opam $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) ++ $(INSTALL) -m 644 pkg/META opam $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) + + install-byte: create-libdir +- $(INSTALL) $(BASE).cma $(LIBDIR) ++ $(INSTALL) -m 644 $(BASE).cma $(LIBDIR) + + install-native: create-libdir +- $(INSTALL) $(BASE).cmxa $(BASE).a $(wildcard $(B)/cmdliner*.cmx) $(LIBDIR) ++ $(INSTALL) -m 644 $(BASE).cmxa $(BASE).a $(wildcard $(B)/cmdliner*.cmx) $(LIBDIR) + + install-native-dynlink: create-libdir +- $(INSTALL) $(BASE).cmxs $(LIBDIR) ++ $(INSTALL) -m 644 $(BASE).cmxs $(LIBDIR) + + .PHONY: all install install-doc clean build-byte build-native \ + build-native-dynlink create-libdir install-common install-byte \ diff --git a/patches/series b/patches/series new file mode 100644 index 0000000..c476b32 --- /dev/null +++ b/patches/series @@ -0,0 +1 @@ +install-x.patch diff --git a/rules b/rules new file mode 100755 index 0000000..0bb5dd6 --- /dev/null +++ b/rules @@ -0,0 +1,19 @@ +#!/usr/bin/make -f +# -*- makefile -*- + +DESTDIR=$(CURDIR)/debian/tmp + +%: + dh $@ --with ocaml --no-parallel + +.PHONY: override_dh_auto_install +override_dh_auto_install: + make DESTDIR=$(DESTDIR) install + +.PHONY: override_dh_install +override_dh_install: + dh_install --exclude=opam + +.PHONY: override_dh_missing +override_dh_missing: + dh_missing --fail-missing diff --git a/source/format b/source/format new file mode 100644 index 0000000..163aaf8 --- /dev/null +++ b/source/format @@ -0,0 +1 @@ +3.0 (quilt) diff --git a/watch b/watch new file mode 100644 index 0000000..5e0f261 --- /dev/null +++ b/watch @@ -0,0 +1,2 @@ +version=3 +http://erratique.ch/software/cmdliner/releases/ .*cmdliner-(.+)\.tbz -- cgit v1.2.3 From d394015a9fa7a2ee3a11929d2d316efc6b3d5844 Mon Sep 17 00:00:00 2001 From: Mehdi Dogguy Date: Fri, 11 May 2018 15:30:44 +0200 Subject: Import cmdliner_1.0.2.orig.tar.bz2 [dgit import orig cmdliner_1.0.2.orig.tar.bz2] --- CHANGES.md | 233 +++++++ LICENSE.md | 13 + Makefile | 69 ++ README.md | 51 ++ _tags | 6 + doc/api.odocl | 1 + opam | 21 + pkg/META | 7 + pkg/pkg.ml | 29 + src/cmdliner.ml | 294 +++++++++ src/cmdliner.mli | 1622 ++++++++++++++++++++++++++++++++++++++++++++++ src/cmdliner.mllib | 11 + src/cmdliner_arg.ml | 358 ++++++++++ src/cmdliner_arg.mli | 113 ++++ src/cmdliner_base.ml | 302 +++++++++ src/cmdliner_base.mli | 74 +++ src/cmdliner_cline.ml | 194 ++++++ src/cmdliner_cline.mli | 34 + src/cmdliner_docgen.ml | 352 ++++++++++ src/cmdliner_docgen.mli | 30 + src/cmdliner_info.ml | 233 +++++++ src/cmdliner_info.mli | 140 ++++ src/cmdliner_manpage.ml | 504 ++++++++++++++ src/cmdliner_manpage.mli | 100 +++ src/cmdliner_msg.ml | 115 ++++ src/cmdliner_msg.mli | 54 ++ src/cmdliner_suggest.ml | 54 ++ src/cmdliner_suggest.mli | 25 + src/cmdliner_term.ml | 43 ++ src/cmdliner_term.mli | 42 ++ src/cmdliner_trie.ml | 97 +++ src/cmdliner_trie.mli | 35 + test/chorus.ml | 31 + test/cp_ex.ml | 54 ++ test/darcs_ex.ml | 149 +++++ test/revolt.ml | 9 + test/rm_ex.ml | 53 ++ test/tail_ex.ml | 74 +++ test/test_man.ml | 100 +++ test/test_man_utf8.ml | 11 + test/test_opt_req.ml | 13 + test/test_pos.ml | 13 + test/test_pos_all.ml | 11 + test/test_pos_left.ml | 11 + test/test_pos_req.ml | 15 + test/test_pos_rev.ml | 14 + test/test_term_dups.ml | 19 + 47 files changed, 5833 insertions(+) create mode 100644 CHANGES.md create mode 100644 LICENSE.md create mode 100644 Makefile create mode 100644 README.md create mode 100644 _tags create mode 100644 doc/api.odocl create mode 100644 opam create mode 100644 pkg/META create mode 100755 pkg/pkg.ml create mode 100644 src/cmdliner.ml create mode 100644 src/cmdliner.mli create mode 100644 src/cmdliner.mllib create mode 100644 src/cmdliner_arg.ml create mode 100644 src/cmdliner_arg.mli create mode 100644 src/cmdliner_base.ml create mode 100644 src/cmdliner_base.mli create mode 100644 src/cmdliner_cline.ml create mode 100644 src/cmdliner_cline.mli create mode 100644 src/cmdliner_docgen.ml create mode 100644 src/cmdliner_docgen.mli create mode 100644 src/cmdliner_info.ml create mode 100644 src/cmdliner_info.mli create mode 100644 src/cmdliner_manpage.ml create mode 100644 src/cmdliner_manpage.mli create mode 100644 src/cmdliner_msg.ml create mode 100644 src/cmdliner_msg.mli create mode 100644 src/cmdliner_suggest.ml create mode 100644 src/cmdliner_suggest.mli create mode 100644 src/cmdliner_term.ml create mode 100644 src/cmdliner_term.mli create mode 100644 src/cmdliner_trie.ml create mode 100644 src/cmdliner_trie.mli create mode 100644 test/chorus.ml create mode 100644 test/cp_ex.ml create mode 100644 test/darcs_ex.ml create mode 100644 test/revolt.ml create mode 100644 test/rm_ex.ml create mode 100644 test/tail_ex.ml create mode 100644 test/test_man.ml create mode 100644 test/test_man_utf8.ml create mode 100644 test/test_opt_req.ml create mode 100644 test/test_pos.ml create mode 100644 test/test_pos_all.ml create mode 100644 test/test_pos_left.ml create mode 100644 test/test_pos_req.ml create mode 100644 test/test_pos_rev.ml create mode 100644 test/test_term_dups.ml diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 0000000..c31b31f --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,233 @@ +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 overriden 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 misterious 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 sub command 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` aswell. 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. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..90fca24 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,13 @@ +Copyright (c) 2011 Daniel C. Bünzli + +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. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..5cbc380 --- /dev/null +++ b/Makefile @@ -0,0 +1,69 @@ +# 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 + +PREFIX=/usr +LIBDIR=$(DESTDIR)$(PREFIX)/lib/ocaml/cmdliner +DOCDIR=$(DESTDIR)$(PREFIX)/share/doc/cmdliner +NATIVE=$(shell ocamlopt -version > /dev/null 2>&1 && echo true) + +INSTALL=install +OCAMLBUILD=ocamlbuild -use-ocamlfind +B=_build/src +BASE=$(B)/cmdliner + +ifeq ($(NATIVE),true) + BUILD-TARGETS=build-byte build-native build-native-dynlink + INSTALL-TARGETS=install-common install-byte install-native \ + install-native-dynlink +else + BUILD-TARGETS=build-byte + INSTALL-TARGETS=install-common install-byte +endif + +all: $(BUILD-TARGETS) + +install: $(INSTALL-TARGETS) + +install-doc: + $(INSTALL) -d $(DOCDIR) + $(INSTALL) CHANGES.md LICENSE.md README.md $(DOCDIR) + +clean: + $(OCAMLBUILD) -clean + +build-byte: + $(OCAMLBUILD) src/cmdliner.cma + +build-native: + $(OCAMLBUILD) src/cmdliner.cmxa + +build-native-dynlink: + $(OCAMLBUILD) src/cmdliner.cmxs + +create-libdir: + $(INSTALL) -d $(LIBDIR) + +install-common: create-libdir + $(INSTALL) pkg/META opam $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) + +install-byte: create-libdir + $(INSTALL) $(BASE).cma $(LIBDIR) + +install-native: create-libdir + $(INSTALL) $(BASE).cmxa $(BASE).a $(wildcard $(B)/cmdliner*.cmx) $(LIBDIR) + +install-native-dynlink: create-libdir + $(INSTALL) $(BASE).cmxs $(LIBDIR) + +.PHONY: all install install-doc clean build-byte build-native \ + build-native-dynlink create-libdir install-common install-byte \ + install-native install-dynlink diff --git a/README.md b/README.md new file mode 100644 index 0000000..4758c8b --- /dev/null +++ b/README.md @@ -0,0 +1,51 @@ +Cmdliner — Declarative definition of command line interfaces for OCaml +------------------------------------------------------------------------------- +v1.0.2 + +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 syntax errors, help messages and UNIX man +page generation. It supports programs with single or multiple commands +and respects most of the [POSIX][1] and [GNU][2] conventions. + +Cmdliner has no dependencies and is distributed under the ISC license. + +[1]: http://pubs.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap12.html +[2]: http://www.gnu.org/software/libc/manual/html_node/Argument-Syntax.html + +Home page: http://erratique.ch/software/cmdliner +Contact: Daniel Bünzli `` + + +## 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 and API reference is automatically generated by from +the source interfaces. It can be consulted [online][doc] or via +`odig doc cmdliner`. + +[doc]: http://erratique.ch/software/cmdliner/doc/Cmdliner + + +## Sample programs + +If you installed Cmdliner with `opam` sample programs are located in +the directory `opam config var cmdliner:doc`. These programs define +the command line of some classic programs. + +In the distribution sample programs are located in the `test` +directory of the distribution. They can be built and run with: + + topkg build --tests true && topkg test diff --git a/_tags b/_tags new file mode 100644 index 0000000..b9b5a6b --- /dev/null +++ b/_tags @@ -0,0 +1,6 @@ +true : bin_annot, safe_string, package(bytes), package(result) + : include + : include + +# Remove once we require >= 4.03 + : warn(-3) \ No newline at end of file diff --git a/doc/api.odocl b/doc/api.odocl new file mode 100644 index 0000000..58711c5 --- /dev/null +++ b/doc/api.odocl @@ -0,0 +1 @@ +Cmdliner diff --git a/opam b/opam new file mode 100644 index 0000000..3678f92 --- /dev/null +++ b/opam @@ -0,0 +1,21 @@ +version: "1.0.2" +opam-version: "1.2" +maintainer: "Daniel Bünzli " +authors: ["Daniel Bünzli "] +homepage: "http://erratique.ch/software/cmdliner" +doc: "http://erratique.ch/software/cmdliner/doc/Cmdliner" +dev-repo: "http://erratique.ch/repos/cmdliner.git" +bug-reports: "https://github.com/dbuenzli/cmdliner/issues" +tags: [ "cli" "system" "declarative" "org:erratique" ] +license: "ISC" +available: [ocaml-version >= "4.01.0"] +depends:[ + "ocamlfind" {build} + "ocamlbuild" {build} + "topkg" {build} + "result" +] +build: [[ + "ocaml" "pkg/pkg.ml" "build" + "--pinned" "%{pinned}%" +]] \ No newline at end of file diff --git a/pkg/META b/pkg/META new file mode 100644 index 0000000..3e23d6f --- /dev/null +++ b/pkg/META @@ -0,0 +1,7 @@ +version = "v1.0.2" +description = "Declarative definition of command line interfaces" +requires = "bytes result" +archive(byte) = "cmdliner.cma" +archive(native) = "cmdliner.cmxa" +plugin(byte) = "cmdliner.cma" +plugin(native) = "cmdliner.cmxs" \ No newline at end of file diff --git a/pkg/pkg.ml b/pkg/pkg.ml new file mode 100755 index 0000000..e53a859 --- /dev/null +++ b/pkg/pkg.ml @@ -0,0 +1,29 @@ +#!/usr/bin/env ocaml +#use "topfind" +#require "topkg" +open Topkg + +let test t = Pkg.flatten [ Pkg.test ~run:false t; Pkg.doc (t ^ ".ml")] + +let distrib = + let exclude_paths () = Ok [".git";".gitignore";".gitattributes";"_build"] in + Pkg.distrib ~exclude_paths () + +let () = + Pkg.describe ~distrib "cmdliner" @@ fun c -> + Ok [ Pkg.mllib ~api:["Cmdliner"] "src/cmdliner.mllib"; + test "test/chorus"; + test "test/cp_ex"; + test "test/darcs_ex"; + test "test/revolt"; + test "test/rm_ex"; + test "test/tail_ex"; + Pkg.test ~run:false "test/test_man"; + Pkg.test ~run:false "test/test_man_utf8"; + Pkg.test ~run:false "test/test_pos"; + Pkg.test ~run:false "test/test_pos_rev"; + Pkg.test ~run:false "test/test_pos_all"; + Pkg.test ~run:false "test/test_pos_left"; + Pkg.test ~run:false "test/test_pos_req"; + Pkg.test ~run:false "test/test_opt_req"; + Pkg.test ~run:false "test/test_term_dups"; ] diff --git a/src/cmdliner.ml b/src/cmdliner.ml new file mode 100644 index 0000000..20d82e3 --- /dev/null +++ b/src/cmdliner.ml @@ -0,0 +1,294 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +open Result + +module Manpage = Cmdliner_manpage +module Arg = Cmdliner_arg +module Term = struct + + include Cmdliner_term + + (* Deprecated *) + + let man_format = Cmdliner_arg.man_format + let pure = const + + (* 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 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 main_name = + Cmdliner_info.Args.empty, + (fun ei _ -> Ok (Cmdliner_info.(term_name @@ eval_main ei))) + + let choice_names = + let choice_name t = Cmdliner_info.term_name t in + Cmdliner_info.Args.empty, + (fun ei _ -> Ok (List.rev_map choice_name (Cmdliner_info.eval_choices ei))) + + (* Term information *) + + type exit_info = Cmdliner_info.exit + let exit_info = Cmdliner_info.exit + + let exit_status_success = 0 + let exit_status_cli_error = 124 + let exit_status_internal_error = 125 + let default_error_exits = + [ exit_info exit_status_cli_error ~doc:"on command line parsing errors."; + exit_info exit_status_internal_error + ~doc:"on unexpected internal errors (bugs)."; ] + + let default_exits = + (exit_info exit_status_success ~doc:"on success.") :: default_error_exits + + type env_info = Cmdliner_info.env + let env_info = Cmdliner_info.env + + type info = Cmdliner_info.term + let info = Cmdliner_info.term ~args:Cmdliner_info.Args.empty + let name ti = Cmdliner_info.term_name ti + + (* Evaluation *) + + let err_help s = "Term error, help requested for unknown command " ^ s + let err_argv = "argv array must have at least one element" + let err_multi_cmd_def name (a, _) (a', _) = + Cmdliner_base.err_multi_def ~kind:"command" name Cmdliner_info.term_doc a a' + + type 'a result = + [ `Ok of 'a | `Error of [`Parse | `Term | `Exn ] | `Version | `Help ] + + let add_stdopts ei = + let docs = Cmdliner_info.(term_stdopts_docs @@ eval_term ei) in + let vargs, vers = match Cmdliner_info.(term_version @@ eval_main ei) with + | None -> Cmdliner_info.Args.empty, None + | Some _ -> + let args, _ as vers = Cmdliner_arg.stdopt_version ~docs in + args, Some vers + in + let help = Cmdliner_arg.stdopt_help ~docs in + let args = Cmdliner_info.Args.union vargs (fst help) in + let term = Cmdliner_info.(term_add_args (eval_term ei) args) in + help, vers, Cmdliner_info.eval_with_term ei term + + type 'a eval_result = + ('a, [ term_escape + | `Exn of exn * Printexc.raw_backtrace + | `Parse of string + | `Std_help of Manpage.format | `Std_version ]) Result.result + + let run ~catch ei cl f = try (f ei cl :> 'a eval_result) with + | exn when catch -> + let bt = Printexc.get_raw_backtrace () in + Error (`Exn (exn, bt)) + + let try_eval_stdopts ~catch ei cl help version = + match run ~catch ei cl (snd help) with + | Ok (Some fmt) -> Some (Error (`Std_help fmt)) + | Error _ as err -> Some err + | Ok None -> + match version with + | None -> None + | Some version -> + match run ~catch ei cl (snd version) with + | Ok false -> None + | Ok true -> Some (Error (`Std_version)) + | Error _ as err -> Some err + + let term_eval ~catch ei f args = + let help, version, ei = add_stdopts ei in + let term_args = Cmdliner_info.(term_args @@ eval_term ei) in + let res = match Cmdliner_cline.create term_args args with + | Error (e, cl) -> + begin match try_eval_stdopts ~catch ei cl help version with + | Some e -> e + | None -> Error (`Error (true, e)) + end + | Ok cl -> + match try_eval_stdopts ~catch ei cl help version with + | Some e -> e + | None -> run ~catch ei cl f + in + ei, res + + let term_eval_peek_opts ei f args = + let help, version, ei = add_stdopts ei in + let term_args = Cmdliner_info.(term_args @@ eval_term ei) in + let v, ret = match Cmdliner_cline.create ~peek_opts:true term_args args with + | Error (e, cl) -> + begin match try_eval_stdopts ~catch:true ei cl help version with + | Some e -> None, e + | None -> None, Error (`Error (true, e)) + end + | Ok cl -> + let ret = run ~catch:true ei cl f in + let v = match ret with Ok v -> Some v | Error _ -> None in + match try_eval_stdopts ~catch:true ei cl help version with + | Some e -> v, e + | None -> v, ret + in + let ret = match ret with + | Ok v -> `Ok v + | Error `Std_help _ -> `Help + | Error `Std_version -> `Version + | Error `Parse _ -> `Error `Parse + | Error `Help _ -> `Help + | Error `Exn _ -> `Error `Exn + | Error `Error _ -> `Error `Term + in + v, ret + + let do_help help_ppf err_ppf ei fmt cmd = + let ei = match cmd with + | None -> Cmdliner_info.(eval_with_term ei @@ eval_main ei) + | Some cmd -> + try + let is_cmd t = Cmdliner_info.term_name t = cmd in + let cmd = List.find is_cmd (Cmdliner_info.eval_choices ei) in + Cmdliner_info.eval_with_term ei cmd + with Not_found -> invalid_arg (err_help cmd) + in + let _, _, ei = add_stdopts ei (* may not be the originally eval'd term *) in + Cmdliner_docgen.pp_man ~errs:err_ppf fmt help_ppf ei + + let do_result help_ppf err_ppf ei = function + | Ok v -> `Ok v + | Error res -> + match res with + | `Std_help fmt -> Cmdliner_docgen.pp_man err_ppf fmt help_ppf ei; `Help + | `Std_version -> Cmdliner_msg.pp_version help_ppf ei; `Version + | `Parse err -> Cmdliner_msg.pp_err_usage err_ppf ei ~err; `Error `Parse + | `Help (fmt, cmd) -> do_help help_ppf err_ppf ei fmt cmd; `Help + | `Exn (e, bt) -> Cmdliner_msg.pp_backtrace err_ppf ei e bt; `Error `Exn + | `Error (usage, err) -> + (if usage + then Cmdliner_msg.pp_err_usage err_ppf ei ~err + else Cmdliner_msg.pp_err err_ppf ei ~err); + `Error `Term + + (* API *) + + let env_default v = try Some (Sys.getenv v) with Not_found -> None + let remove_exec argv = + try List.tl (Array.to_list argv) with Failure _ -> invalid_arg err_argv + + let eval + ?help:(help_ppf = Format.std_formatter) + ?err:(err_ppf = Format.err_formatter) + ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) ((al, f), ti) = + let term = Cmdliner_info.term_add_args ti al in + let ei = Cmdliner_info.eval ~term ~main:term ~choices:[] ~env in + let args = remove_exec argv in + let ei, res = term_eval ~catch ei f args in + do_result help_ppf err_ppf ei res + + let choose_term main choices = function + | [] -> Ok (main, []) + | maybe :: args' as args -> + if String.length maybe > 1 && maybe.[0] = '-' then Ok (main, args) else + let index = + let add acc (choice, _ as c) = + let name = Cmdliner_info.term_name choice in + match Cmdliner_trie.add acc name c with + | `New t -> t + | `Replaced (c', _) -> invalid_arg (err_multi_cmd_def name c c') + in + List.fold_left add Cmdliner_trie.empty choices + in + match Cmdliner_trie.find index maybe with + | `Ok choice -> Ok (choice, args') + | `Not_found -> + let all = Cmdliner_trie.ambiguities index "" in + let hints = Cmdliner_suggest.value maybe all in + Error (Cmdliner_base.err_unknown ~kind:"command" maybe ~hints) + | `Ambiguous -> + let ambs = Cmdliner_trie.ambiguities index maybe in + let ambs = List.sort compare ambs in + Error (Cmdliner_base.err_ambiguous ~kind:"command" maybe ~ambs) + + let eval_choice + ?help:(help_ppf = Format.std_formatter) + ?err:(err_ppf = Format.err_formatter) + ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) + main choices = + let to_term_f ((al, f), ti) = Cmdliner_info.term_add_args ti al, f in + let choices_f = List.rev_map to_term_f choices in + let main_f = to_term_f main in + let choices = List.rev_map fst choices_f in + let main = fst main_f in + match choose_term main_f choices_f (remove_exec argv) with + | Error err -> + let ei = Cmdliner_info.eval ~term:main ~main ~choices ~env in + Cmdliner_msg.pp_err_usage err_ppf ei ~err; `Error `Parse + | Ok ((chosen, f), args) -> + let ei = Cmdliner_info.eval ~term:chosen ~main ~choices ~env in + let ei, res = term_eval ~catch ei f args in + do_result help_ppf err_ppf ei res + + let eval_peek_opts + ?(version_opt = false) ?(env = env_default) ?(argv = Sys.argv) + ((args, f) : 'a t) = + let version = if version_opt then Some "dummy" else None in + let term = Cmdliner_info.term ~args ?version "dummy" in + let ei = Cmdliner_info.eval ~term ~main:term ~choices:[] ~env in + (term_eval_peek_opts ei f (remove_exec argv) :> 'a option * 'a result) + + (* Exits *) + + let exit_status_of_result ?(term_err = 1) = function + | `Ok _ | `Help | `Version -> exit_status_success + | `Error `Term -> term_err + | `Error `Exn -> exit_status_internal_error + | `Error `Parse -> exit_status_cli_error + + let exit_status_of_status_result ?term_err = function + | `Ok n -> n + | r -> exit_status_of_result ?term_err r + + let exit ?term_err r = Pervasives.exit (exit_status_of_result ?term_err r) + let exit_status ?term_err r = + Pervasives.exit (exit_status_of_status_result ?term_err r) + +end + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner.mli b/src/cmdliner.mli new file mode 100644 index 0000000..fbbb20b --- /dev/null +++ b/src/cmdliner.mli @@ -0,0 +1,1622 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +(** Declarative definition of command line interfaces. + + [Cmdliner] provides a simple and compositional mechanism + to convert command line arguments to OCaml values and pass them to + your functions. The module automatically handles syntax errors, + help messages and UNIX man page generation. It supports programs + with single or multiple commands + (like [darcs] or [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. + + Consult the {{!basics}basics}, details about the supported + {{!cmdline}command line syntax} and {{!examples} examples} of + use. Open the module to use it, it defines only three modules in + your scope. + + {e v1.0.2 — {{:http://erratique.ch/software/cmdliner }homepage}} *) + +(** {1:top Interface} *) + +open Result + +(** Man page specification. + + Man page generation is automatically handled by [Cmdliner], + consult the {{!manual}details}. + + The {!block} type is used to define a man page's content. It's a + good idea to follow the {{!standard_sections}standard} manual page + structure. + + {b References.} + {ul + {- [man-pages(7)], {{:http://man7.org/linux/man-pages/man7/man-pages.7.html} + {e Conventions for writing Linux man pages}}.}} *) +module Manpage : sig + + (** {1:man Man pages} *) + + type block = + [ `S of string | `P of string | `Pre of string | `I of string * string + | `Noblank | `Blocks of block list ] + (** The type for a block of man page text. + + {ul + {- [`S s] introduces a new section [s], see the + {{!standard_sections}standard section names}.} + {- [`P t] is a new paragraph with text [t].} + {- [`Pre t] is a new preformatted paragraph with text [t].} + {- [`I (l,t)] is an indented paragraph with label + [l] and text [t].} + {- [`Noblank] suppresses the blank line introduced between two blocks.} + {- [`Blocks bs] splices the blocks [bs].}} + + Except in [`Pre], whitespace and newlines are not significant + and are all collapsed to a single space. All block strings + support the {{!doclang}documentation markup language}.*) + + val escape : string -> string + (** [escape s] escapes [s] so that it doesn't get interpreted by the + {{!doclang}documentation markup language}. *) + + type title = string * int * string * string * string + (** The type for man page titles. Describes the man page + [title], [section], [center_footer], [left_footer], [center_header]. *) + + type t = title * block list + (** The type for a man page. A title and the page text as a list of blocks. *) + + type xref = + [ `Main | `Cmd of string | `Tool of string | `Page of string * int ] + (** The type for man page cross-references. + {ul + {- [`Main] refers to the man page of the program itself.} + {- [`Cmd cmd] refers to the man page of the program's [cmd] + command (which must exist).} + {- [`Tool bin] refers to the command line tool named [bin].} + {- [`Page (name, sec)] refers to the man page [name(sec)].}} *) + + (** {1:standard_sections Standard section names and content} + + The following are standard man page section names, roughly ordered + in the order they conventionally appear. See also + {{:http://man7.org/linux/man-pages/man7/man-pages.7.html}[man man-pages]} + for more elaborations about what sections should contain. *) + + val s_name : string + (** The [NAME] section. This section is automatically created by + [Cmdliner] for your. *) + + val s_synopsis : string + (** The [SYNOPSIS] section. By default this section is automatically + created by [Cmdliner] for you, unless it is the first section of + your term's man page, in which case it will replace it with yours. *) + + val s_description : string + (** The [DESCRIPTION] section. This should be a description of what + the tool does and provide a little bit of usage and + documentation guidance. *) + + val s_commands : string + (** The [COMMANDS] section. By default subcommands get listed here. *) + + val s_arguments : string + (** The [ARGUMENTS] section. By default positional arguments get + listed here. *) + + val s_options : string + (** The [OPTIONS] section. By default options and flag arguments get + listed here. *) + + val s_common_options : string + (** The [COMMON OPTIONS] section. For programs with multiple commands + a section that can be used to gather options common to all commands. *) + + val s_exit_status : string + (** The [EXIT STATUS] section. By default term status exit codes + get listed here. *) + + val s_environment : string + (** The [ENVIRONMENT] section. By default environment variables get + listed here. *) + + val s_environment_intro : block + (** [s_environment_intro] is the introduction content used by cmdliner + when it creates the {!s_environment} section. *) + + val s_files : string + (** The [FILES] section. *) + + val s_bugs : string + (** The [BUGS] section. *) + + val s_examples : string + (** The [EXAMPLES] section. *) + + val s_authors : string + (** The [AUTHORS] section. *) + + val s_see_also : string + (** The [SEE ALSO] section. *) + + (** {1:output Output} + + The {!print} function can be useful if the client wants to define + other man pages (e.g. to implement a help command). *) + + type format = [ `Auto | `Pager | `Plain | `Groff ] + (** The type for man page output specification. + {ul + {- [`Auto], formats like [`Pager] or [`Plain] whenever the [TERM] + environment variable is [dumb] or unset.} + {- [`Pager], tries to write to a discovered pager, if that fails + uses the [`Plain] format.} + {- [`Plain], formats to plain text.} + {- [`Groff], formats to groff commands.}} *) + + val print : + ?errs:Format.formatter -> + ?subst:(string -> string option) -> format -> Format.formatter -> t -> unit + (** [print ~errs ~subst fmt ppf page] prints [page] on [ppf] in the + format [fmt]. [subst] can be used to perform variable + substitution,(defaults to the identity). [errs] is used to print + formatting errors, it defaults to {!Format.err_formatter}. *) +end + +(** Terms. + + A term is evaluated by a program to produce a {{!result}result}, + which can be turned into an {{!exits}exit status}. A term made of terms + referring to {{!Arg}command line arguments} implicitly defines a + command line syntax. *) +module Term : sig + + (** {1:terms Terms} *) + + type +'a t + (** The type for terms evaluating to values of type 'a. *) + + val const : 'a -> 'a t + (** [const v] is a term that evaluates to [v]. *) + + (**/**) + val pure : 'a -> 'a t + (** @deprecated use {!const} instead. *) + + val man_format : Manpage.format t + (** @deprecated Use {!Arg.man_format} instead. *) + (**/**) + + val ( $ ) : ('a -> 'b) t -> 'a t -> 'b t + (** [f $ v] is a term that evaluates to the result of applying + the evaluation of [v] to the one of [f]. *) + + val app : ('a -> 'b) t -> 'a t -> 'b t + (** [app] is {!($)}. *) + + (** {1 Interacting with Cmdliner's evaluation} *) + + type 'a ret = + [ `Help of Manpage.format * string option + | `Error of (bool * string) + | `Ok of 'a ] + (** The type for command return values. See {!ret}. *) + + val ret : 'a ret t -> 'a t + (** [ret v] is a term whose evaluation depends on the case + to which [v] evaluates. With : + {ul + {- [`Ok v], it evaluates to [v].} + {- [`Error (usage, e)], the evaluation fails and [Cmdliner] prints + the error [e] and the term's usage if [usage] is [true].} + {- [`Help (format, name)], the evaluation fails and [Cmdliner] prints the + term's man page in the given [format] (or the man page for a + specific [name] term in case of multiple term evaluation).}} *) + + val term_result : ?usage:bool -> ('a, [`Msg of string]) result t -> 'a t + (** [term_result ~usage t] evaluates to + {ul + {- [`Ok v] if [t] evaluates to [Ok v]} + {- [`Error `Term] with the error message [e] and usage shown according + to [usage] (defaults to [false]), if [t] evaluates to + [Error (`Msg e)].}} *) + + val cli_parse_result : ('a, [`Msg of string]) result t -> 'a t + (** [cli_parse_result t] is a term that evaluates to: + {ul + {- [`Ok v] if [t] evaluates to [Ok v].} + {- [`Error `Parse] with the error message [e] + if [t] evaluates to [Error (`Msg e)].}} *) + + val main_name : string t + (** [main_name] is a term that evaluates to the "main" term's name. *) + + val choice_names : string list t + (** [choice_names] is a term that evaluates to the names of the terms + to choose from. *) + + (** {1:tinfo Term information} + + Term information defines the name and man page of a term. + For simple evaluation this is the name of the program and its + man page. For multiple term evaluation, this is + the name of a command and its man page. *) + + type exit_info + (** The type for exit status information. *) + + val exit_info : ?docs:string -> ?doc:string -> ?max:int -> int -> exit_info + (** [exit_info ~docs ~doc min ~max] describe the range of exit + statuses from [min] to [max] (defaults to [min]). [doc] is the + man page information for the statuses, defaults to ["undocumented"]. + [docs] is the title of the man page section in which the statuses + will be listed, it defaults to {!Manpage.s_exit_status}. + + In [doc] the {{!doclang}documentation markup language} can be + used with following variables: + {ul + {- [$(status)], the value of [min].} + {- [$(status_max)], the value of [max].} + {- The variables mentioned in {!info}}} *) + + val default_exits : exit_info list + (** [default_exits] is information for exit status {!exit_status_success} + added to {!default_error_exits}. *) + + val default_error_exits : exit_info list + (** [default_error_exits] is information for exit statuses + {!exit_status_cli_error} and {!exit_status_internal_error}. *) + + type env_info + (** The type for environment variable information. *) + + val env_info : ?docs:string -> ?doc:string -> string -> env_info + (** [env_info ~docs ~doc var] describes an environment variable + [var]. [doc] is the man page information of the environment + variable, defaults to ["undocumented"]. [docs] is the title of + the man page section in which the environment variable will be + listed, it defaults to {!Manpage.s_environment}. + + In [doc] the {{!doclang}documentation markup language} can be + used with following variables: + {ul + {- [$(env)], the value of [var].} + {- The variables mentioned in {!info}}} *) + + type info + (** The type for term information. *) + + val info : + ?man_xrefs:Manpage.xref list -> ?man:Manpage.block list -> + ?envs:env_info list -> ?exits:exit_info list -> ?sdocs:string -> + ?docs:string -> ?doc:string -> ?version:string -> string -> info + (** [info sdocs man docs doc version name] is a term information + such that: + {ul + {- [name] is the name of the program or the command.} + {- [version] is the version string of the program, ignored + for commands.} + {- [doc] is a one line description of the program or command used + for the [NAME] section of the term's man page. For commands this + description is also used in the list of commands of the main + term's man page.} + {- [docs], only for commands, the title of the section of the main + term's man page where it should be listed (defaults to + {!Manpage.s_commands}).} + {- [sdocs] defines the title of the section in which the + standard [--help] and [--version] arguments are listed + (defaults to {!Manpage.s_options}).} + {- [exits] is a list of exit statuses that the term evaluation + may produce.} + {- [envs] is a list of environment variables that influence + the term's evaluation.} + {- [man] is the text of the man page for the term.} + {- [man_xrefs] are cross-references to other manual pages. These + are used to generate a {!Manpage.s_see_also} section.}} + [doc], [man], [envs] support the {{!doclang}documentation markup + language} in which the following variables are recognized: + {ul + {- [$(tname)] the term's name.} + {- [$(mname)] the main term's name.}} *) + + val name : info -> string + (** [name ti] is the name of the term information. *) + + (** {1:evaluation Evaluation} *) + + type 'a result = + [ `Ok of 'a | `Error of [`Parse | `Term | `Exn ] | `Version | `Help ] + (** The type for evaluation results. + {ul + {- [`Ok v], the term evaluated successfully and [v] is the result.} + {- [`Version], the version string of the main term was printed + on the help formatter.} + {- [`Help], man page about the term was printed on the help formatter.} + {- [`Error `Parse], a command line parse error occurred and was + reported on the error formatter.} + {- [`Error `Term], a term evaluation error occurred and was reported + on the error formatter (see {!Term.ret}).} + {- [`Error `Exn], an exception [e] was caught and reported + on the error formatter (see the [~catch] parameter of {!eval}).}} *) + + val eval : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> ('a t * info) -> + 'a result + (** [eval help err catch argv (t,i)] is the evaluation result + of [t] with command line arguments [argv] (defaults to {!Sys.argv}). + + If [catch] is [true] (default) uncaught exceptions + are intercepted and their stack trace is written to the [err] + formatter. + + [help] is the formatter used to print help or version messages + (defaults to {!Format.std_formatter}). [err] is the formatter + used to print error messages (defaults to {!Format.err_formatter}). + + [env] is used for environment variable lookup, the default + uses {!Sys.getenv}. *) + + val eval_choice : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + 'a t * info -> ('a t * info) list -> 'a result + (** [eval_choice help err catch argv (t,i) choices] is like {!eval} + except that if the first argument on the command line is not an option + name it will look in [choices] for a term whose information has this + name and evaluate it. + + If the command name is unknown an error is reported. If the name + is unspecified the "main" term [t] is evaluated. [i] defines the + name and man page of the program. *) + + val eval_peek_opts : + ?version_opt:bool -> ?env:(string -> string option) -> + ?argv:string array -> 'a t -> 'a option * 'a result + (** [eval_peek_opts version_opt argv t] evaluates [t], a term made + of optional arguments only, with the command line [argv] + (defaults to {!Sys.argv}). In this evaluation, unknown optional + arguments and positional arguments are ignored. + + The evaluation returns a pair. The first component is + the result of parsing the command line [argv] stripped from + any help and version option if [version_opt] is [true] (defaults + to [false]). It results in: + {ul + {- [Some _] if the command line would be parsed correctly given the + {e partial} knowledge in [t].} + {- [None] if a parse error would occur on the options of [t]}} + + The second component is the result of parsing the command line + [argv] without stripping the help and version options. It + indicates what the evaluation would result in on [argv] given + the partial knowledge in [t] (for example it would return + [`Help] if there's a help option in [argv]). However in + contrasts to {!eval} and {!eval_choice} no side effects like + error reporting or help output occurs. + + {b Note.} Positional arguments can't be peeked without the full + specification of the command line: we can't tell apart a + positional argument from the value of an unknown optional + argument. *) + + (** {1:exits Turning evaluation results into exit codes} + + {b Note.} If you are using the following functions to handle + the evaluation result of a term you should add {!default_exits} to + the term's information {{!info}[~exits]} argument. + + {b WARNING.} You should avoid status codes strictly greater than 125 + as those may be used by + {{:https://www.gnu.org/software/bash/manual/html_node/Exit-Status.html} + some} shells. *) + + val exit_status_success : int + (** [exit_status_success] is 0, the exit status for success. *) + + val exit_status_cli_error : int + (** [exit_status_cli_error] is 124, an exit status for command line + parsing errors. *) + + val exit_status_internal_error : int + (** [exit_status_internal_error] is 125, an exit status for unexpected + internal errors. *) + + val exit_status_of_result : ?term_err:int -> 'a result -> int + (** [exit_status_of_result ~term_err r] is an [exit(3)] status + code determined from [r] as follows: + {ul + {- {!exit_status_success} if [r] is one of [`Ok _], [`Version], [`Help]} + {- [term_err] if [r] is [`Error `Term], [term_err] defaults to [1].} + {- {!exit_status_cli_error} if [r] is [`Error `Parse]} + {- {!exit_status_internal_error} if [r] is [`Error `Exn]}} *) + + val exit_status_of_status_result : ?term_err:int -> int result -> int + (** [exit_status_of_status_result] is like {!exit_status_of_result} + except for [`Ok n] where [n] is used as the status exit code. *) + + val exit : ?term_err:int -> 'a result -> unit + (** [exit ~term_err r] is + [Pervasives.exit @@ exit_status_of_result ~term_err r] *) + + val exit_status : ?term_err:int -> int result -> unit + (** [exit_status ~term_err r] is + [Pervasives.exit @@ exit_status_of_status_result ~term_err r] *) +end + +(** Terms for command line arguments. + + This module provides functions to define terms that evaluate + to the arguments provided on the command line. + + Basic constraints, like the argument type or repeatability, are + specified by defining a value of type {!t}. Further constraints can + be specified during the {{!argterms}conversion} to a term. *) +module Arg : sig + +(** {1:argconv Argument converters} + + An argument converter transforms a string argument of the command + line to an OCaml value. {{!converters}Predefined converters} + are provided for many types of the standard library. *) + + type 'a parser = string -> [ `Ok of 'a | `Error of string ] + (** The type for argument parsers. + + @deprecated Use a parser with [('a, [ `Msg of string]) result] results + and {!conv}. *) + + type 'a printer = Format.formatter -> 'a -> unit + (** The type for converted argument printers. *) + + type 'a conv = 'a parser * 'a printer + (** The type for argument converters. + + {b WARNING.} This type will become abstract in the next + major version of cmdliner, use {!val:conv} or {!pconv} + to construct values of this type. *) + + type 'a converter = 'a conv + (** @deprecated Use the {!type:conv} type via the {!val:conv} and {!pconv} + functions. *) + + val conv : + ?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a printer -> + 'a conv + (** [converter ~docv (parse, print)] is an argument converter + parsing values with [parse] and printing them with + [print]. [docv] is a documentation meta-variable used in the + documentation to stand for the argument value, defaults to + ["VALUE"]. *) + + val pconv : + ?docv:string -> 'a parser * 'a printer -> 'a conv + (** [pconv] is like {!converter}, but uses a deprecated {!parser} + signature. *) + + val conv_parser : 'a conv -> (string -> ('a, [`Msg of string]) result) + (** [conv_parser c] 's [c]'s parser. *) + + val conv_printer : 'a conv -> 'a printer + (** [conv_printer c] is [c]'s printer. *) + + val conv_docv : 'a conv -> string + (** [conv_docv c] is [c]'s documentation meta-variable. + + {b WARNING.} Currently always returns ["VALUE"] in the future + will return the value given to {!conv} or {!pconv}. *) + + val parser_of_kind_of_string : + kind:string -> (string -> 'a option) -> + (string -> ('a, [`Msg of string]) result) + (** [parser_of_kind_of_string ~kind kind_of_string] is an argument + parser using the [kind_of_string] function for parsing and [kind] + to report errors (e.g. could be ["an integer"] for an [int] parser.). *) + + val some : ?none:string -> 'a conv -> 'a option conv + (** [some none c] is like the converter [c] except it returns + [Some] value. It is used for command line arguments + that default to [None] when absent. [none] is what to print to + document the absence (defaults to [""]). *) + +(** {1:arginfo Arguments and their information} + + Argument information defines the man page information of an + argument and, for optional arguments, its names. An environment + variable can also be specified to read the argument value from + if the argument is absent from the command line and the variable + is defined. *) + + type env = Term.env_info + (** The type for environment variables and their documentation. *) + + val env_var : ?docs:string -> ?doc:string -> string -> env + (** [env_var docs doc var] is an environment variables [var]. [doc] + is the man page information of the environment variable, the + {{!doclang}documentation markup language} with the variables + mentioned in {!info} be used; it defaults to ["See option + $(opt)."]. [docs] is the title of the man page section in which + the environment variable will be listed, it defaults to + {!Manpage.s_environment}. *) + + type 'a t + (** The type for arguments holding data of type ['a]. *) + + type info + (** The type for information about command line arguments. *) + + val info : + ?docs:string -> ?docv:string -> ?doc:string -> ?env:env -> string list -> + info + (** [info docs docv doc env names] defines information for + an argument. + {ul + {- [names] defines the names under which an optional argument + can be referred to. Strings of length [1] (["c"]) define + short option names (["-c"]), longer strings (["count"]) + define long option names (["--count"]). [names] must be empty + for positional arguments.} + {- [env] defines the name of an environment variable which is + looked up for defining the argument if it is absent from the + command line. See {{!envlookup}environment variables} for + details.} + {- [doc] is the man page information of the argument. + The {{!doclang}documentation language} can be used and + the following variables are recognized: + {ul + {- ["$(docv)"] the value of [docv] (see below).} + {- ["$(opt)"], one of the options of [names], preference + is given to a long one.} + {- ["$(env)"], the environment var specified by [env] (if any).}} + {{!doc_helpers}These functions} can help with formatting argument + values.} + {- [docv] is for positional and non-flag optional arguments. + It is a variable name used in the man page to stand for their value.} + {- [docs] is the title of the man page section in which the argument + will be listed. For optional arguments this defaults + to {!Manpage.s_options}. For positional arguments this defaults + to {!Manpage.s_arguments}. However a positional argument is only + listed if it has both a [doc] and [docv] specified.}} *) + + val ( & ) : ('a -> 'b) -> 'a -> 'b + (** [f & v] is [f v], a right associative composition operator for + specifying argument terms. *) + +(** {1:optargs Optional arguments} + + The information of an optional argument must have at least + one name or [Invalid_argument] is raised. *) + + val flag : info -> bool t + (** [flag i] is a [bool] argument defined by an optional flag + that may appear {e at most} once on the command line under one of + the names specified by [i]. The argument holds [true] if the + flag is present on the command line and [false] otherwise. *) + + val flag_all : info -> bool list t + (** [flag_all] is like {!flag} except the flag may appear more than + once. The argument holds a list that contains one [true] value per + occurrence of the flag. It holds the empty list if the flag + is absent from the command line. *) + + val vflag : 'a -> ('a * info) list -> 'a t + (** [vflag v \[v]{_0}[,i]{_0}[;...\]] is an ['a] argument defined + by an optional flag that may appear {e at most} once on + the command line under one of the names specified in the [i]{_k} + values. The argument holds [v] if the flag is absent from the + command line and the value [v]{_k} if the name under which it appears + is in [i]{_k}. + + {b Note.} Environment variable lookup is unsupported for + for these arguments. *) + + val vflag_all : 'a list -> ('a * info) list -> 'a list t + (** [vflag_all v l] is like {!vflag} except the flag may appear more + than once. The argument holds the list [v] if the flag is absent + from the command line. Otherwise it holds a list that contains one + corresponding value per occurrence of the flag, in the order found on + the command line. + + {b Note.} Environment variable lookup is unsupported for + for these arguments. *) + + val opt : ?vopt:'a -> 'a conv -> 'a -> info -> 'a t + (** [opt vopt c v i] is an ['a] argument defined by the value of + an optional argument that may appear {e at most} once on the command + line under one of the names specified by [i]. The argument holds + [v] if the option is absent from the command line. Otherwise + it has the value of the option as converted by [c]. + + If [vopt] is provided the value of the optional argument is itself + optional, taking the value [vopt] if unspecified on the command line. *) + + val opt_all : ?vopt:'a -> 'a conv -> 'a list -> info -> 'a list t + (** [opt_all vopt c v i] is like {!opt} except the optional argument may + appear more than once. The argument holds a list that contains one value + per occurrence of the flag in the order found on the command line. + It holds the list [v] if the flag is absent from the command line. *) + + (** {1:posargs Positional arguments} + + The information of a positional argument must have no name + or [Invalid_argument] is raised. Positional arguments indexing + is zero-based. + + {b Warning.} The following combinators allow to specify and + extract a given positional argument with more than one term. + This should not be done as it will likely confuse end users and + documentation generation. These over-specifications may be + prevented by raising [Invalid_argument] in the future. But for now + it is the client's duty to make sure this doesn't happen. *) + + val pos : ?rev:bool -> int -> 'a conv -> 'a -> info -> 'a t + (** [pos rev n c v i] is an ['a] argument defined by the [n]th + positional argument of the command line as converted by [c]. + If the positional argument is absent from the command line + the argument is [v]. + + If [rev] is [true] (defaults to [false]), the computed + position is [max-n] where [max] is the position of + the last positional argument present on the command line. *) + + val pos_all : 'a conv -> 'a list -> info -> 'a list t + (** [pos_all c v i] is an ['a list] argument that holds + all the positional arguments of the command line as converted + by [c] or [v] if there are none. *) + + val pos_left : + ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t + (** [pos_left rev n c v i] is an ['a list] argument that holds + all the positional arguments as converted by [c] found on the left + of the [n]th positional argument or [v] if there are none. + + If [rev] is [true] (defaults to [false]), the computed + position is [max-n] where [max] is the position of + the last positional argument present on the command line. *) + + val pos_right : + ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t + (** [pos_right] is like {!pos_left} except it holds all the positional + arguments found on the right of the specified positional argument. *) + + (** {1:argterms Arguments as terms} *) + + val value : 'a t -> 'a Term.t + (** [value a] is a term that evaluates to [a]'s value. *) + + val required : 'a option t -> 'a Term.t + (** [required a] is a term that fails if [a]'s value is [None] and + evaluates to the value of [Some] otherwise. Use this for required + positional arguments (it can also be used for defining required + optional arguments, but from a user interface perspective this + shouldn't be done, it is a contradiction in terms). *) + + val non_empty : 'a list t -> 'a list Term.t + (** [non_empty a] is term that fails if [a]'s list is empty and + evaluates to [a]'s list otherwise. Use this for non empty lists + of positional arguments. *) + + val last : 'a list t -> 'a Term.t + (** [last a] is a term that fails if [a]'s list is empty and evaluates + to the value of the last element of the list otherwise. Use this + for lists of flags or options where the last occurrence takes precedence + over the others. *) + + (** {1:predef Predefined arguments} *) + + val man_format : Manpage.format Term.t + (** [man_format] is a term that defines a [--man-format] option and + evaluates to a value that can be used with {!Manpage.print}. *) + + (** {1:converters Predefined converters} *) + + val bool : bool conv + (** [bool] converts values with {!bool_of_string}. *) + + val char : char conv + (** [char] converts values by ensuring the argument has a single char. *) + + val int : int conv + (** [int] converts values with {!int_of_string}. *) + + val nativeint : nativeint conv + (** [nativeint] converts values with {!Nativeint.of_string}. *) + + val int32 : int32 conv + (** [int32] converts values with {!Int32.of_string}. *) + + val int64 : int64 conv + (** [int64] converts values with {!Int64.of_string}. *) + + val float : float conv + (** [float] converts values with {!float_of_string}. *) + + val string : string conv + (** [string] converts values with the identity function. *) + + val enum : (string * 'a) list -> 'a conv + (** [enum l p] converts values such that unambiguous prefixes of string names + in [l] map to the corresponding value of type ['a]. + + {b Warning.} The type ['a] must be comparable with {!Pervasives.compare}. + + @raise Invalid_argument if [l] is empty. *) + + val file : string conv + (** [file] converts a value with the identity function and + checks with {!Sys.file_exists} that a file with that name exists. *) + + val dir : string conv + (** [dir] converts a value with the identity function and checks + with {!Sys.file_exists} and {!Sys.is_directory} + that a directory with that name exists. *) + + val non_dir_file : string conv + (** [non_dir_file] converts a value with the identity function and checks + with {!Sys.file_exists} and {!Sys.is_directory} + that a non directory file with that name exists. *) + + val list : ?sep:char -> 'a conv -> 'a list conv + (** [list sep c] splits the argument at each [sep] (defaults to [',']) + character and converts each substrings with [c]. *) + + val array : ?sep:char -> 'a conv -> 'a array conv + (** [array sep c] splits the argument at each [sep] (defaults to [',']) + character and converts each substring with [c]. *) + + val pair : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv + (** [pair sep c0 c1] splits the argument at the {e first} [sep] character + (defaults to [',']) and respectively converts the substrings with + [c0] and [c1]. *) + + val t2 : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv + (** {!t2} is {!pair}. *) + + val t3 : ?sep:char -> 'a conv ->'b conv -> 'c conv -> ('a * 'b * 'c) conv + (** [t3 sep c0 c1 c2] splits the argument at the {e first} two [sep] + characters (defaults to [',']) and respectively converts the + substrings with [c0], [c1] and [c2]. *) + + val t4 : + ?sep:char -> 'a conv -> 'b conv -> 'c conv -> 'd conv -> + ('a * 'b * 'c * 'd) conv + (** [t4 sep c0 c1 c2 c3] splits the argument at the {e first} three [sep] + characters (defaults to [',']) respectively converts the substrings + with [c0], [c1], [c2] and [c3]. *) + + (** {1:doc_helpers Documentation formatting helpers} *) + + val doc_quote : string -> string + (** [doc_quote s] quotes the string [s]. *) + + val doc_alts : ?quoted:bool -> string list -> string + (** [doc_alts alts] documents the alternative tokens [alts] according + the number of alternatives. If [quoted] is [true] (default) + the tokens are quoted. The resulting string can be used in + sentences of the form ["$(docv) must be %s"]. + + @raise Invalid_argument if [alts] is the empty string. *) + + val doc_alts_enum : ?quoted:bool -> (string * 'a) list -> string + (** [doc_alts_enum quoted alts] is [doc_alts quoted (List.map fst alts)]. *) +end + +(** {1:basics Basics} + + With [Cmdliner] your program evaluates a term. A {e term} is a value + of type {!Term.t}. The type parameter indicates the type of the + result of the evaluation. + +One way to create terms is by lifting regular OCaml values with +{!Term.const}. Terms can be applied to terms evaluating to functional +values with {!Term.( $ )}. For example for the function: + +{[ +let revolt () = print_endline "Revolt!" +]} + +the term : + +{[ +open Cmdliner + +let revolt_t = Term.(const revolt $ const ()) +]} + +is a term that evaluates to the result (and effect) of the [revolt] +function. Terms are evaluated with {!Term.eval}: + +{[ +let () = Term.exit @@ Term.eval (revolt_t, Term.info "revolt") +]} + +This defines a command line program named ["revolt"], without command +line arguments, that just prints ["Revolt!"] on [stdout]. + +{[ +> ./revolt +Revolt! +]} + +The combinators in the {!Arg} module allow to extract command line +argument data as terms. These terms can then be applied to lifted +OCaml functions to be evaluated by the program. + +Terms corresponding to command line argument data that are part of a +term evaluation implicitly define a command line syntax. We show this +on an concrete example. + +Consider the [chorus] function that prints repeatedly a given message : + +{[ +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: + +{[ +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: + +{[ +let count = + let doc = "Repeat the message $(docv) times." in + Arg.(value & opt int 10 & info ["c"; "count"] ~docv:"COUNT" ~doc) +]} + +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: + +{[ +let msg = + let doc = "Overrides the default message to print." in + let env = Arg.env_var "CHORUS_MSG" ~doc in + let doc = "The message to print." in + Arg.(value & pos 0 string "Revolt!" & info [] ~env ~docv:"MSG" ~doc) +]} + +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. + +The term for executing [chorus] with these command line arguments is : + +{[ +let chorus_t = Term.(const chorus $ count $ msg) +]} + +and we are now ready to define our program: + +{[ +let info = + let doc = "print a customizable message repeatedly" in + let man = [ + `S Manpage.s_bugs; + `P "Email bug reports to ." ] + in + Term.info "chorus" ~version:"%‌%VERSION%%" ~doc ~exits:Term.default_exits ~man + +let () = Term.exit @@ Term.eval (chorus_t, info)) +]} + +The [info] value created with {!Term.info} gives more information +about the term we execute and is used to generate the program's man +page. Since we provided a [~version] string, the program will +automatically respond to the [--version] option by printing this +string. + +A program using {!Term.eval} always responds to the [--help] option by +showing the man page about the program generated using the information +you provided with {!Term.info} and {!Arg.info}. Here is the output +generated by our example : + +{v +> ./chorus --help +NAME + chorus - print a customizable message repeatedly + +SYNOPSIS + chorus [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. + + --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. + + 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 . +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]. + +For examples of more complex command line definitions look and run +the {{!examples}examples}. + +{2:multiterms Multiple terms} + +[Cmdliner] also provides support for programs like [darcs] or [git] +that have multiple commands each with their own syntax: + +{[prog COMMAND [OPTION]... ARG...]} + +A command is defined by coupling a term with {{!Term.tinfo}term +information}. The term information defines the command name and its +man page. Given a list of commands the function {!Term.eval_choice} +will execute the term corresponding to the [COMMAND] argument or or a +specific "main" term if there is no [COMMAND] argument. + +{2:doclang Documentation markup language} + +Manpage {{!Manpage.block}blocks} and doc strings 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 term's + man page [$(tname)] is substituted by the term name 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.} +{- Refering to unknown markup directives or variables will generate + errors on standard error during documentation generation.}} + +{2:manual Manual} + +Man page sections for a term are printed in the order specified by the +term manual as given to {!Term.info}. Unless specified explicitely in +the term's manual the following sections are automaticaly created and +populated for you: + +{ul +{- {{!Manpage.s_name}[NAME]} section.} +{- {{!Manpage.s_synopsis}[SYNOPSIS]} section.}} + +The various [doc] documentation strings specified by the term's +subterms and additional metadata get inserted at the end of the +documentation section name [docs] they respectively mention, in the +following order: + +{ol +{- Commands, see {!Term.info}.} +{- Positional arguments, see {!Arg.info}. Those are listed iff + both the [docv] and [doc] string is specified by {!Arg.info}.} +{- Optional arguments, see {!Arg.info}.} +{- Exit statuses, see {!Term.exit_info}.} +{- Environment variables, see {!Arg.env_var} and {!Term.env_info}.}} + +If a [docs] section name is mentioned and does not exist in the term's +manual, an empty section is created for it, after which the [doc] strings +are inserted, possibly prefixed by boilerplate text (e.g. for +{!Manpage.s_environment} and {!Manpage.s_exit_status}). + +If the created section is: +{ul +{- {{!Manpage.standard_sections}standard}, it + is inserted at the right place in the order specified + {{!Manpage.standard_sections}here}, but after a possible non-standard + section explicitely specified by the term since the latter get the + order number of the last previously specified standard section + or the order of {!Manpage.s_synopsis} if there is no such section.} +{- non-standard, it is inserted before the {!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 term's + manual.}} + +Ideally all manual strings should be UTF-8 encoded. However at the +moment macOS (until at least 10.12) is stuck with [groff 1.19.2] which +doesn't support `preconv(1)`. Regarding UTF-8 output, generating the +man page with [-Tutf8] maps the hyphen-minus [U+002D] to the minus +sign [U+2212] which makes it difficult to search it in the pager, so +[-Tascii] is used for now. Conclusion is that it is better to stick +to the ASCII set for now. Please contact the author if something seems +wrong in this reasoning or if you know a work around this. + +{2:misc Miscellaneous} + +{ul +{- The option name [--cmdliner] is 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:cmdline Command line syntax} + +For programs evaluating a single term the most general form of invocation is: + +{[ +prog [OPTION]... [ARG]... +]} + +The program automatically reponds to the [--help] option by printing +the help. If a version string is provided in the {{!Term.tinfo}term +information}, it also automatically responds to the [--version] option +by printing this string. + +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. + +Programs evaluating multiple terms also add this form of invocation: + +{[ +prog COMMAND [OPTION]... [ARG]... +]} + +Commands automatically respond to the [--help] option by printing +their help. The [COMMAND] string must be the first string following +the program name and may be specified by a prefix as long as it is not +ambiguous. + +{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. Long names can be specified by any non +ambiguous prefix. + +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 +{!Arg.flag}, {!Arg.vflag}) or an optional argument with an optional +value (see the [~vopt] argument of {!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. + +{2: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 that +the environment variable is defined, its value is parsed using the +argument converter and defines the value of the argument. + +For {!Arg.flag} and {!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 {!Arg.vflag} and +{!Arg.vflag_all}. + +{1:examples Examples} + +These examples are in the [test] directory of the distribution. + +{2:exrm A [rm] command} + +We define the command line interface of a [rm] command with the synopsis: + +{[ +rm [OPTION]... FILE... +]} + +The [-f], [-i] and [-I] flags define the prompt behaviour of [rm], +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 {!Arg.vflag_all}. This argument +will contain all occurrences of the flag on the command line and we +just take the {!Arg.last} one to define our term value (if there's no +occurrence the last value of the default list [[Always]] is taken, +i.e. the default is [Always]). + +{[ +(* 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 + +let files = Arg.(non_empty & pos_all file [] & info [] ~docv:"FILE") +let prompt = + let doc = "Prompt before every removal." in + let always = Always, Arg.info ["i"] ~doc in + let doc = "Ignore nonexistent files and never prompt." in + let never = Never, Arg.info ["f"; "force"] ~doc in + 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 + let once = 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 cmd = + let doc = "remove files or directories" in + let man = [ + `S Manpage.s_description; + `P "$(tname) 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 `-', for example + `-foo', use one of these commands:"; + `P "rm -- -foo"; `Noblank; + `P "rm ./-foo"; + `P "$(tname) removes symbolic links, not the files referenced by the + links."; + `S Manpage.s_bugs; `P "Report bugs to ."; + `S Manpage.s_see_also; `P "$(b,rmdir)(1), $(b,unlink)(2)" ] + in + Term.(const rm $ prompt $ recursive $ files), + Term.info "rm" ~version:"v1.0.2" ~doc ~exits:Term.default_exits ~man + +let () = Term.(exit @@ eval cmd) +]} + +{2:excp A [cp] command} + +We define the command line interface of a [cp] command with the synopsis: +{[ +cp [OPTION]... SOURCE... DEST +]} + +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 {!Arg}. Hence we just give it the {!Arg.string} type +and verify the constraint at the beginning of the [cp] +implementation. If unsatisfied we return an [`Error] and by using +{!Term.ret} on the lifted result [cp_t] of [cp], [Cmdliner] handles +the error reporting. + +{[ +(* Implementation, we check the dest argument and print the args *) + +let cp verbose recurse force srcs dest = + if List.length srcs > 1 && + (not (Sys.file_exists dest) || not (Sys.is_directory dest)) + then + `Error (false, dest ^ " is 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 + +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 + Arg.(required & pos ~rev:true 0 (some string) None & info [] ~docv:"DEST" + ~doc) + +let cmd = + let doc = "copy files" in + let man_xrefs = + [ `Tool "mv"; `Tool "scp"; `Page (2, "umask"); `Page (7, "symlink") ] + in + let exits = Term.default_exits in + let man = + [ `S Manpage.s_bugs; + `P "Email them to ."; ] + in + Term.(ret (const cp $ verbose $ recurse $ force $ srcs $ dest)), + Term.info "cp" ~version:"v1.0.2" ~doc ~exits ~man ~man_xrefs + +let () = Term.(exit @@ eval cmd) +]} + +{2:extail A [tail] command} + +We define the command line interface of a [tail] command with the +synopsis: + +{[ +tail [OPTION]... [FILE]... +]} + +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.argconv}argument +converter} for this option. + +The [--follow] option has an optional enumerated value. The argument +converter [follow], created with {!Arg.enum} parses the option value +into the enumeration. By using {!Arg.some} and the [~vopt] argument of +{!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. + +{[ +(* 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 Result +open Cmdliner + +let lines = + let loc = + let parse 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 (`Msg "unable to parse integer") + in + let print ppf p = Format.fprintf ppf "%s" (loc_str p) in + Arg.conv ~docv:"N" (parse, print) + in + Arg.(value & opt loc (true, 10) & info ["n"; "lines"] ~docv:"N" + ~doc:"Output the last $(docv) lines or use $(i,+)$(docv) to start + output after the $(i,N)-1th line.") + +let follow = + let doc = "Output appended data as the file grows. $(docv) specifies how the + file should be tracked, by its `name' or by its `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 doc = "Never output headers giving file names." in + let quiet = Quiet, Arg.info ["q"; "quiet"; "silent"] ~doc in + let doc = "Always output headers giving file names." in + let verbose = 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 cmd = + let doc = "display the last part of a file" in + let man = [ + `S Manpage.s_description; + `P "$(tname) 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 ."; + `S Manpage.s_see_also; + `P "$(b,cat)(1), $(b,head)(1)" ] + in + Term.(const tail $ lines $ follow $ verb $ pid $ files), + Term.info "tail" ~version:"%‌%VERSION%%" ~doc ~exits:Term.default_exits ~man + +let () = Term.(exit @@ eval cmd) +]} + +{2:exdarcs A [darcs] command} + +We define the command line interface of a [darcs] command with the +synopsis: + +{[ +darcs [COMMAND] ... +]} + +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 a section called [COMMON +OPTIONS], since we also want to put [--help] and [--version] in this +section, the term information of commands makes a judicious use of the +[sdocs] parameter of {!Term.info}. + +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 {!Term.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 [no_cmd] term. + +{[ +(* 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 + match conv 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 + +(* 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 `$(mname) $(i,COMMAND) --help' for help on a single command.";`Noblank; + `P "Use `$(mname) help patterns' for help on patch matching."; `Noblank; + `P "Use `$(mname) 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 $(mname) command." in + Arg.(value & opt (some string) None & info ["prehook"] ~docs ~doc) + in + Term.(const copts $ debug $ verb $ prehook) + +(* Commands *) + +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 exits = Term.default_exits 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 + Term.(const initialize $ copts_t $ repodir), + Term.info "initialize" ~doc ~sdocs:Manpage.s_common_options ~exits ~man + +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 exits = Term.default_exits 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 + Term.(const record $ copts_t $ pname $ author $ all $ ask_deps $ files), + Term.info "record" ~doc ~sdocs:Manpage.s_common_options ~exits ~man + +let help_cmd = + let topic = + let doc = "The topic to get help on. `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 + Term.(ret + (const help $ copts_t $ Arg.man_format $ Term.choice_names $topic)), + Term.info "help" ~doc ~exits:Term.default_exits ~man + +let default_cmd = + let doc = "a revision control system" in + let sdocs = Manpage.s_common_options in + let exits = Term.default_exits in + let man = help_secs in + Term.(ret (const (fun _ -> `Help (`Pager, None)) $ copts_t)), + Term.info "darcs" ~version:"v1.0.2" ~doc ~sdocs ~exits ~man + +let cmds = [initialize_cmd; record_cmd; help_cmd] + +let () = Term.(exit @@ eval_choice default_cmd cmds) +]} +*) + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner.mllib b/src/cmdliner.mllib new file mode 100644 index 0000000..f1ec5a3 --- /dev/null +++ b/src/cmdliner.mllib @@ -0,0 +1,11 @@ +Cmdliner_suggest +Cmdliner_trie +Cmdliner_base +Cmdliner_manpage +Cmdliner_info +Cmdliner_docgen +Cmdliner_msg +Cmdliner_cline +Cmdliner_arg +Cmdliner_term +Cmdliner diff --git a/src/cmdliner_arg.ml b/src/cmdliner_arg.ml new file mode 100644 index 0000000..1bf0ff5 --- /dev/null +++ b/src/cmdliner_arg.ml @@ -0,0 +1,358 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +open Result + +let rev_compare n0 n1 = compare n1 n0 + +(* Invalid_argument strings **) + +let err_not_opt = "Option argument without name" +let err_not_pos = "Positional argument with a name" + +(* Documentation formatting helpers *) + +let strf = Printf.sprintf +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 () + +(* Argument converters *) + +type 'a parser = string -> [ `Ok of 'a | `Error of string ] +type 'a printer = Format.formatter -> 'a -> unit + +type 'a conv = 'a parser * 'a printer +type 'a converter = 'a conv + +let default_docv = "VALUE" +let conv ?docv (parse, print) = + let parse s = match parse s with Ok v -> `Ok v | Error (`Msg e) -> `Error e in + parse, print + +let pconv ?docv conv = conv + +let conv_parser (parse, _) = + fun s -> match parse s with `Ok v -> Ok v | `Error e -> Error (`Msg e) + +let conv_printer (_, print) = print +let conv_docv _ = default_docv + +let err_invalid s kind = `Msg (strf "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 + +let some = Cmdliner_base.some + +(* Argument information *) + +type env = Cmdliner_info.env +let env_var = Cmdliner_info.env + +type 'a t = 'a Cmdliner_term.t +type info = Cmdliner_info.arg +let info = Cmdliner_info.arg + +(* Arguments *) + +let ( & ) f x = f x + +let err e = Error (`Parse e) + +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_info.arg_env a with +| None -> Ok absent +| Some env -> + let var = Cmdliner_info.env_var env in + match Cmdliner_info.(eval_env_var ei var) with + | None -> Ok absent + | Some v -> + match parse v with + | `Ok v -> Ok v + | `Error e -> err (Cmdliner_msg.err_env_parse env ~err:e) + +let arg_to_args = Cmdliner_info.Args.singleton +let list_to_args f l = + let add acc v = Cmdliner_info.Args.add (f v) acc in + List.fold_left add Cmdliner_info.Args.empty l + +let flag a = + if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else + let convert ei cl = match Cmdliner_cline.opt_arg cl a with + | [] -> try_env ei a Cmdliner_base.env_bool_parse ~absent:false + | [_, _, None] -> Ok true + | [_, f, Some v] -> err (Cmdliner_msg.err_flag_value f v) + | (_, f, _) :: (_ ,g, _) :: _ -> err (Cmdliner_msg.err_opt_repeated f g) + in + arg_to_args a, convert + +let flag_all a = + if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else + let a = Cmdliner_info.arg_make_all_opts a in + let convert ei cl = match Cmdliner_cline.opt_arg cl a with + | [] -> + try_env ei a (parse_to_list Cmdliner_base.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 -> err e + in + arg_to_args a, convert + +let vflag v l = + let convert _ cl = + let rec aux fv = function + | (v, a) :: rest -> + begin match Cmdliner_cline.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 -> err e + in + let flag (_, a) = + if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else a + in + list_to_args flag l, convert + +let vflag_all v l = + let convert _ cl = + let rec aux acc = function + | (fv, a) :: rest -> + begin match Cmdliner_cline.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 -> err e + in + let flag (_, a) = + if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else + Cmdliner_info.arg_make_all_opts a + in + list_to_args flag l, convert + +let parse_opt_value parse f v = match parse v with +| `Ok v -> v +| `Error e -> failwith (Cmdliner_msg.err_opt_parse f e) + +let opt ?vopt (parse, print) v a = + if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else + let absent = Cmdliner_info.Val (lazy (str_of_pp print v)) in + let kind = match vopt with + | None -> Cmdliner_info.Opt + | Some dv -> Cmdliner_info.Opt_vopt (str_of_pp print dv) + in + let a = Cmdliner_info.arg_make_opt ~absent ~kind a in + let convert ei cl = match Cmdliner_cline.opt_arg cl a with + | [] -> try_env ei a parse ~absent:v + | [_, f, Some v] -> + (try Ok (parse_opt_value parse f v) with Failure e -> err e) + | [_, f, None] -> + begin match vopt with + | None -> err (Cmdliner_msg.err_opt_value_missing f) + | Some optv -> Ok optv + end + | (_, f, _) :: (_, g, _) :: _ -> err (Cmdliner_msg.err_opt_repeated g f) + in + arg_to_args a, convert + +let opt_all ?vopt (parse, print) v a = + if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else + let absent = Cmdliner_info.Val (lazy "") in + let kind = match vopt with + | None -> Cmdliner_info.Opt + | Some dv -> Cmdliner_info.Opt_vopt (str_of_pp print dv) + in + let a = Cmdliner_info.arg_make_opt_all ~absent ~kind a in + let convert ei cl = match Cmdliner_cline.opt_arg cl a with + | [] -> try_env ei a (parse_to_list parse) ~absent:v + | l -> + let parse (k, f, v) = match v with + | Some v -> (k, parse_opt_value parse 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 -> err e + in + arg_to_args a, convert + +(* Positional arguments *) + +let parse_pos_value parse a v = match parse v with +| `Ok v -> v +| `Error e -> failwith (Cmdliner_msg.err_pos_parse a e) + +let pos ?(rev = false) k (parse, print) v a = + if Cmdliner_info.arg_is_opt a then invalid_arg err_not_pos else + let absent = Cmdliner_info.Val (lazy (str_of_pp print v)) in + let pos = Cmdliner_info.pos ~rev ~start:k ~len:(Some 1) in + let a = Cmdliner_info.arg_make_pos_abs ~absent ~pos a in + let convert ei cl = match Cmdliner_cline.pos_arg cl a with + | [] -> try_env ei a parse ~absent:v + | [v] -> + (try Ok (parse_pos_value parse a v) with Failure e -> err e) + | _ -> assert false + in + arg_to_args a, convert + +let pos_list pos (parse, _) v a = + if Cmdliner_info.arg_is_opt a then invalid_arg err_not_pos else + let a = Cmdliner_info.arg_make_pos pos a in + let convert ei cl = match Cmdliner_cline.pos_arg cl a with + | [] -> try_env ei a (parse_to_list parse) ~absent:v + | l -> + try Ok (List.rev (List.rev_map (parse_pos_value parse a) l)) with + | Failure e -> err e + in + arg_to_args a, convert + +let all = Cmdliner_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_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_info.pos ~rev ~start ~len) + +(* Arguments as terms *) + +let absent_error args = + let make_req a acc = + let req_a = Cmdliner_info.arg_make_req a in + Cmdliner_info.Args.add req_a acc + in + Cmdliner_info.Args.fold make_req args Cmdliner_info.Args.empty + +let value a = a + +let err_arg_missing args = + err @@ Cmdliner_msg.err_arg_missing (Cmdliner_info.Args.choose args) + +let required (args, convert) = + let args = absent_error args in + let convert ei cl = match convert ei cl with + | Ok (Some v) -> Ok v + | Ok None -> err_arg_missing args + | Error _ as e -> e + in + args, convert + +let non_empty (al, convert) = + let args = absent_error al in + let convert ei cl = match convert ei cl with + | Ok [] -> err_arg_missing args + | Ok l -> Ok l + | Error _ as e -> e + in + args, convert + +let last (args, convert) = + let convert ei cl = match convert ei cl with + | Ok [] -> err_arg_missing args + | Ok l -> Ok (List.hd (List.rev l)) + | Error _ as e -> e + in + args, convert + +(* Predefined arguments *) + +let man_fmts = + ["auto", `Auto; "pager", `Pager; "groff", `Groff; "plain", `Plain] + +let man_fmt_docv = "FMT" +let man_fmts_enum = Cmdliner_base.enum man_fmts +let man_fmts_alts = doc_alts_enum man_fmts +let man_fmts_doc kind = + strf "Show %s in format $(docv). The value $(docv) must be %s. With `auto', + the format is `pager` or `plain' whenever the $(b,TERM) env var is + `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 + +(* Predefined converters. *) + +let bool = Cmdliner_base.bool +let char = Cmdliner_base.char +let int = Cmdliner_base.int +let nativeint = Cmdliner_base.nativeint +let int32 = Cmdliner_base.int32 +let int64 = Cmdliner_base.int64 +let float = Cmdliner_base.float +let string = Cmdliner_base.string +let enum = Cmdliner_base.enum +let file = Cmdliner_base.file +let dir = Cmdliner_base.dir +let non_dir_file = Cmdliner_base.non_dir_file +let list = Cmdliner_base.list +let array = Cmdliner_base.array +let pair = Cmdliner_base.pair +let t2 = Cmdliner_base.t2 +let t3 = Cmdliner_base.t3 +let t4 = Cmdliner_base.t4 + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_arg.mli b/src/cmdliner_arg.mli new file mode 100644 index 0000000..7d7e318 --- /dev/null +++ b/src/cmdliner_arg.mli @@ -0,0 +1,113 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +open Result + +(** Command line arguments as terms. *) + +type 'a parser = string -> [ `Ok of 'a | `Error of string ] +type 'a printer = Format.formatter -> 'a -> unit +type 'a conv = 'a parser * 'a printer +type 'a converter = 'a conv + +val conv : + ?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a printer -> + 'a conv + +val pconv : ?docv:string -> 'a parser * 'a printer -> '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) + +val some : ?none:string -> 'a converter -> 'a option converter + +type env = Cmdliner_info.env +val env_var : ?docs:string -> ?doc:string -> string -> env + +type 'a t = 'a Cmdliner_term.t + +type info +val info : + ?docs:string -> ?docv:string -> ?doc:string -> ?env:env -> 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 converter -> 'a -> info -> 'a t +val opt_all : ?vopt:'a -> 'a converter -> 'a list -> info -> 'a list t + +val pos : ?rev:bool -> int -> 'a converter -> 'a -> info -> 'a t +val pos_all : 'a converter -> 'a list -> info -> 'a list t +val pos_left : ?rev:bool -> int -> 'a converter -> 'a list -> info -> 'a list t +val pos_right : ?rev:bool -> int -> 'a converter -> 'a list -> info -> 'a list t + +(** {1 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 + +(** {1 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 + +(** {1 Converters} *) + +val bool : bool converter +val char : char converter +val int : int converter +val nativeint : nativeint converter +val int32 : int32 converter +val int64 : int64 converter +val float : float converter +val string : string converter +val enum : (string * 'a) list -> 'a converter +val file : string converter +val dir : string converter +val non_dir_file : string converter +val list : ?sep:char -> 'a converter -> 'a list converter +val array : ?sep:char -> 'a converter -> 'a array converter +val pair : ?sep:char -> 'a converter -> 'b converter -> ('a * 'b) converter +val t2 : ?sep:char -> 'a converter -> 'b converter -> ('a * 'b) converter + +val t3 : + ?sep:char -> 'a converter ->'b converter -> 'c converter -> + ('a * 'b * 'c) converter + +val t4 : + ?sep:char -> 'a converter ->'b converter -> 'c converter -> 'd converter -> + ('a * 'b * 'c * 'd) converter + +val doc_quote : string -> string +val doc_alts : ?quoted:bool -> string list -> string +val doc_alts_enum : ?quoted:bool -> (string * 'a) list -> string + + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_base.ml b/src/cmdliner_base.ml new file mode 100644 index 0000000..a925d18 --- /dev/null +++ b/src/cmdliner_base.ml @@ -0,0 +1,302 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +(* Invalid argument strings *) + +let err_empty_list = "empty list" +let err_incomplete_enum = "Incomplete enumeration for the type" + +(* String helpers, should be migrated to ascii_ versions once >= 4.03 *) + +let lowercase = String.lowercase +let uppercase = String.lowercase +let capitalize = String.capitalize + +(* Formatting tools *) + +let strf = Printf.sprintf +let pp = Format.fprintf +let pp_sp = Format.pp_print_space +let pp_str = Format.pp_print_string +let pp_char = Format.pp_print_char + +let pp_white_str ~spaces ppf s = (* hint spaces (maybe) and new lines. *) + let left = ref 0 and right = ref 0 and len = String.length s in + let flush () = + Format.pp_print_string ppf (String.sub s !left (!right - !left)); + incr right; left := !right; + in + while (!right <> len) do + if s.[!right] = '\n' then (flush (); Format.pp_force_newline ppf ()) else + if spaces && s.[!right] = ' ' then (flush (); Format.pp_print_space ppf ()) + else incr right; + done; + if !left <> len then flush () + +let pp_text = pp_white_str ~spaces:true +let pp_lines = pp_white_str ~spaces:false + +let pp_tokens ~spaces ppf s = (* collapse white and hint spaces (maybe) *) + let is_space = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false in + let i_max = String.length s - 1 in + let flush start stop = pp_str 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 pp_sp ppf () else pp_char ppf ' '; + if next_start > i_max then () else loop next_start next_start) + in + loop 0 0 + +(* Converter (end-user) error messages *) + +let quote s = strf "`%s'" s +let alts_str ?(quoted = true) alts = + let quote = if quoted then quote else (fun s -> s) in + match alts with + | [] -> invalid_arg err_empty_list + | [a] -> (quote a) + | [a; b] -> strf "either %s or %s" (quote a) (quote b) + | alts -> + let rev_alts = List.rev alts in + strf "one of %s or %s" + (String.concat ", " (List.rev_map quote (List.tl rev_alts))) + (quote (List.hd rev_alts)) + +let err_multi_def ~kind name doc v v' = + strf "%s %s defined twice (doc strings are '%s' and '%s')" + kind name (doc v) (doc v') + +let err_ambiguous ~kind s ~ambs = + strf "%s %s ambiguous and could be %s" kind (quote s) (alts_str ambs) + +let err_unknown ?(hints = []) ~kind v = + let did_you_mean s = strf ", did you mean %s ?" s in + let hints = match hints with [] -> "." | hs -> did_you_mean (alts_str hs) in + strf "unknown %s %s%s" kind (quote v) hints + +let err_no kind s = strf "no %s %s" (quote s) kind +let err_not_dir s = strf "%s is not a directory" (quote s) +let err_is_dir s = strf "%s is a directory" (quote s) +let err_element kind s exp = + strf "invalid element in %s (`%s'): %s" kind s exp + +let err_invalid kind s exp = strf "invalid %s %s, %s" kind (quote s) exp +let err_invalid_val = err_invalid "value" +let err_sep_miss sep s = + err_invalid_val s (strf "missing a `%c' separator" sep) + +(* Converters *) + +type 'a parser = string -> [ `Ok of 'a | `Error of string ] +type 'a printer = Format.formatter -> 'a -> unit +type 'a conv = 'a parser * 'a printer + +let some ?(none = "") (parse, print) = + let parse s = match parse s with + | `Ok v -> `Ok (Some v) + | `Error _ as e -> e + in + let print ppf v = match v with + | None -> Format.pp_print_string ppf none + | Some v -> print ppf v + in + parse, print + +let bool = + let parse s = try `Ok (bool_of_string s) with + | Invalid_argument _ -> + `Error (err_invalid_val s (alts_str ["true"; "false"])) + in + parse, Format.pp_print_bool + +let char = + let parse s = match String.length s = 1 with + | true -> `Ok s.[0] + | false -> `Error (err_invalid_val s "expected a character") + in + parse, pp_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 = + parse_with int_of_string "expected an integer", Format.pp_print_int + +let int32 = + parse_with Int32.of_string "expected a 32-bit integer", + (fun ppf -> pp ppf "%ld") + +let int64 = + parse_with Int64.of_string "expected a 64-bit integer", + (fun ppf -> pp ppf "%Ld") + +let nativeint = + parse_with Nativeint.of_string "expected a processor-native integer", + (fun ppf -> pp ppf "%nd") + +let float = + parse_with float_of_string "expected a floating point number", + Format.pp_print_float + +let string = (fun s -> `Ok s), pp_str +let enum sl = + if sl = [] then invalid_arg err_empty_list else + let t = Cmdliner_trie.of_list sl in + let parse s = match Cmdliner_trie.find t s with + | `Ok _ as r -> r + | `Ambiguous -> + let ambs = List.sort compare (Cmdliner_trie.ambiguities t s) in + `Error (err_ambiguous "enum value" s ambs) + | `Not_found -> + let alts = List.rev (List.rev_map (fun (s, _) -> s) sl) in + `Error (err_invalid_val s ("expected " ^ (alts_str alts))) + in + let print ppf v = + let sl_inv = List.rev_map (fun (s,v) -> (v,s)) sl in + try pp_str ppf (List.assoc v sl_inv) + with Not_found -> invalid_arg err_incomplete_enum + in + parse, print + +let file = + let parse s = match Sys.file_exists s with + | true -> `Ok s + | false -> `Error (err_no "file or directory" s) + in + parse, pp_str + +let dir = + let parse s = match Sys.file_exists s with + | true -> if Sys.is_directory s then `Ok s else `Error (err_not_dir s) + | false -> `Error (err_no "directory" s) + in + parse, pp_str + +let non_dir_file = + let parse s = match Sys.file_exists s with + | true -> if not (Sys.is_directory s) then `Ok s else `Error (err_is_dir s) + | false -> `Error (err_no "file" s) + in + parse, pp_str + +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 = ',') (parse, pp_e) = + let parse s = try `Ok (split_and_parse sep parse s) with + | Failure e -> `Error (err_element "list" s e) + in + let rec print ppf = function + | v :: l -> pp_e ppf v; if (l <> []) then (pp_char ppf sep; print ppf l) + | [] -> () + in + parse, print + +let array ?(sep = ',') (parse, pp_e) = + let parse s = try `Ok (Array.of_list (split_and_parse sep parse s)) with + | Failure e -> `Error (err_element "array" s e) + in + let print ppf v = + let max = Array.length v - 1 in + for i = 0 to max do pp_e ppf v.(i); if i <> max then pp_char ppf sep done + in + parse, print + +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 = ',') (pa0, pr0) (pa1, pr1) = + let parser s = match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some (v0, v1) -> + match pa0 v0, pa1 v1 with + | `Ok v0, `Ok v1 -> `Ok (v0, v1) + | `Error e, _ | _, `Error e -> `Error (err_element "pair" s e) + in + let printer ppf (v0, v1) = pp ppf "%a%c%a" pr0 v0 sep pr1 v1 in + parser, printer + +let t2 = pair +let t3 ?(sep = ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) = + let parse 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 pa0 v0, pa1 v1, pa2 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 print ppf (v0, v1, v2) = + pp ppf "%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2 + in + parse, print + +let t4 ?(sep = ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) (pa3, pr3) = + let parse 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 pa0 v0, pa1 v1, pa2 v2, pa3 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 print ppf (v0, v1, v2, v3) = + pp ppf "%a%c%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2 sep pr3 v3 + in + parse, print + +let env_bool_parse s = match lowercase s with +| "" | "false" | "no" | "n" | "0" -> `Ok false +| "true" | "yes" | "y" | "1" -> `Ok true +| s -> `Error (err_invalid_val s (alts_str ["true"; "yes"; "false"; "no" ])) + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_base.mli b/src/cmdliner_base.mli new file mode 100644 index 0000000..50b8e1e --- /dev/null +++ b/src/cmdliner_base.mli @@ -0,0 +1,74 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +(** A few helpful base definitions. *) + +(** {1:str String helpers} *) + +val lowercase : string -> string +val uppercase : string -> string +val capitalize : string -> string + +(** {1:fmt Formatting helpers} *) + +val pp_text : Format.formatter -> string -> unit +val pp_lines : Format.formatter -> string -> unit +val pp_tokens : spaces:bool -> Format.formatter -> string -> unit + +(** {1:err Error message helpers} *) + +val quote : string -> string +val alts_str : ?quoted:bool -> string list -> string +val err_ambiguous : kind:string -> string -> ambs:string list -> string +val err_unknown : ?hints:string list -> kind:string -> string -> string +val err_multi_def : + kind:string -> string -> ('b -> string) -> 'b -> 'b -> string + +(** {1:conv Textual OCaml value converters} *) + +type 'a parser = string -> [ `Ok of 'a | `Error of string ] +type 'a printer = Format.formatter -> 'a -> unit +type 'a conv = 'a parser * 'a printer + +val some : ?none:string -> 'a conv -> 'a option conv +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 : (string * 'a) list -> 'a 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 env_bool_parse : bool parser + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_cline.ml b/src/cmdliner_cline.ml new file mode 100644 index 0000000..6825b47 --- /dev/null +++ b/src/cmdliner_cline.ml @@ -0,0 +1,194 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +open Result + +(* A command line stores pre-parsed information about the command + line's arguments in a more structured way. Given the + Cmdliner_info.arg values mentioned in a term and Sys.argv + (without exec name) we parse the command line into a map of + Cmdliner_info.arg values to [arg] values (see below). This map is used by + the term's closures to retrieve and convert command line arguments + (see the Cmdliner_arg module). *) + +let err_multi_opt_name_def name a a' = + Cmdliner_base.err_multi_def + ~kind:"option name" name Cmdliner_info.arg_doc a a' + +module Amap = Map.Make (Cmdliner_info.Arg) + +type 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 + +type t = arg Amap.t (* command line, maps arg_infos to arg value. *) + +let get_arg cl a = try Amap.find a cl with Not_found -> assert false +let opt_arg cl a = match get_arg cl a with O l -> l | _ -> assert false +let pos_arg cl a = match get_arg cl a with P l -> l | _ -> assert false + +let arg_info_indexes args = + (* 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 cmdline mapping each arg_info to an empty [arg]. *) + let rec loop optidx posidx cl = function + | [] -> optidx, posidx, cl + | a :: l -> + match Cmdliner_info.arg_is_pos a with + | true -> loop optidx (a :: posidx) (Amap.add a (P []) cl) l + | false -> + let add t name = match Cmdliner_trie.add t name a with + | `New t -> t + | `Replaced (a', _) -> invalid_arg (err_multi_opt_name_def name a a') + in + let names = Cmdliner_info.arg_opt_names a in + let optidx = List.fold_left add optidx names in + loop optidx posidx (Amap.add a (O []) cl) l + in + loop Cmdliner_trie.empty [] Amap.empty (Cmdliner_info.Args.elements args) + +(* Optional argument parsing *) + +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. *) + let l = String.length s in + if s.[1] <> '-' then (* short opt *) + if l = 2 then s, None else + String.sub s 0 2, Some (String.sub s 2 (l - 2)) (* with glued opt arg *) + else try (* long opt *) + let i = String.index s '=' in + String.sub s 0 i, Some (String.sub s (i + 1) (l - i - 1)) + with Not_found -> s, None + +let hint_matching_opt optidx s = + (* hint options that could match [s] in [optidx]. FIXME explain this is + a bit obscure. *) + 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_suggest.value 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_args ~peek_opts optidx cl args = + (* returns an updated [cl] 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 cl pargs = function + | [] -> List.rev errs, cl, List.rev pargs + | "--" :: args -> List.rev errs, cl, (List.rev_append pargs args) + | s :: args -> + if not (is_opt s) then loop errs (k + 1) cl (s :: pargs) args else + let name, value = parse_opt_arg s in + match Cmdliner_trie.find optidx name with + | `Ok a -> + let value, args = match value, Cmdliner_info.arg_opt_kind a with + | Some v, Cmdliner_info.Flag when is_short_opt name -> + None, ("-" ^ v) :: args + | Some _, _ -> value, args + | None, Cmdliner_info.Flag -> value, args + | None, _ -> + match args with + | [] -> None, args + | v :: rest -> if is_opt v then None, args else Some v, rest + in + let arg = O ((k, name, value) :: opt_arg cl a) in + loop errs (k + 1) (Amap.add a arg cl) pargs args + | `Not_found when peek_opts -> loop errs (k + 1) cl pargs args + | `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) cl pargs args + | `Ambiguous -> + let ambs = Cmdliner_trie.ambiguities optidx name in + let ambs = List.sort compare ambs in + let err = Cmdliner_base.err_ambiguous "option" name ambs in + loop (err :: errs) (k + 1) cl pargs args + in + let errs, cl, pargs = loop [] 0 cl [] args in + if errs = [] then Ok (cl, pargs) else + let err = String.concat "\n" errs in + Error (err, cl, pargs) + +let take_range start stop l = + let rec loop i acc = function + | [] -> List.rev acc + | v :: vs -> + if i < start then loop (i + 1) acc vs else + if i <= stop then loop (i + 1) (v :: acc) vs else + List.rev acc + in + loop 0 [] l + +let process_pos_args posidx cl pargs = + (* returns an updated [cl] 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_info.arg_is_req posidx in + if misses = [] then Ok cl else + Error (Cmdliner_msg.err_pos_misses misses, cl) + else + let last = List.length pargs - 1 in + let pos rev k = if rev then last - k else k in + let rec loop misses cl max_spec = function + | [] -> misses, cl, max_spec + | a :: al -> + let apos = Cmdliner_info.arg_pos a in + let rev = Cmdliner_info.pos_rev apos in + let start = pos rev (Cmdliner_info.pos_start apos) in + let stop = match Cmdliner_info.pos_len apos with + | None -> pos rev last + | Some n -> pos rev (Cmdliner_info.pos_start apos + n - 1) + in + let start, stop = if rev then stop, start else start, stop in + let args = take_range start stop pargs in + let max_spec = max stop max_spec in + let cl = Amap.add a (P args) cl in + let misses = match Cmdliner_info.arg_is_req a && args = [] with + | true -> a :: misses + | false -> misses + in + loop misses cl max_spec al + in + let misses, cl, max_spec = loop [] cl (-1) posidx in + if misses <> [] then Error (Cmdliner_msg.err_pos_misses misses, cl) else + if last <= max_spec then Ok cl else + let excess = take_range (max_spec + 1) last pargs in + Error (Cmdliner_msg.err_pos_excess excess, cl) + +let create ?(peek_opts = false) al args = + let optidx, posidx, cl = arg_info_indexes al in + match parse_opt_args ~peek_opts optidx cl args with + | Ok (cl, _) when peek_opts -> Ok cl + | Ok (cl, pargs) -> process_pos_args posidx cl pargs + | Error (errs, cl, _) -> Error (errs, cl) + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_cline.mli b/src/cmdliner_cline.mli new file mode 100644 index 0000000..28072ad --- /dev/null +++ b/src/cmdliner_cline.mli @@ -0,0 +1,34 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +open Result + +(** Command lines. *) + +type t + +val create : + ?peek_opts:bool -> Cmdliner_info.args -> string list -> + (t, string * t) result + +val opt_arg : t -> Cmdliner_info.arg -> (int * string * (string option)) list +val pos_arg : t -> Cmdliner_info.arg -> string list + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_docgen.ml b/src/cmdliner_docgen.ml new file mode 100644 index 0000000..555f3bd --- /dev/null +++ b/src/cmdliner_docgen.ml @@ -0,0 +1,352 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +let rev_compare n0 n1 = compare n1 n0 +let strf = Printf.sprintf + +let esc = Cmdliner_manpage.escape +let term_name t = esc @@ Cmdliner_info.term_name t + +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 + +(* Doc string variables substitutions. *) + +let env_info_subst ~subst e = function +| "env" -> Some (strf "$(b,%s)" @@ esc (Cmdliner_info.env_var e)) +| id -> subst id + +let exit_info_subst ~subst e = function +| "status" -> Some (strf "%d" (fst @@ Cmdliner_info.exit_statuses e)) +| "status_max" -> Some (strf "%d" (snd @@ Cmdliner_info.exit_statuses e)) +| id -> subst id + +let arg_info_subst ~subst a = function +| "docv" -> + Some (strf "$(i,%s)" @@ esc (Cmdliner_info.arg_docv a)) +| "opt" when Cmdliner_info.arg_is_opt a -> + Some (strf "$(b,%s)" @@ esc (Cmdliner_info.arg_opt_name_sample a)) +| "env" as id -> + begin match Cmdliner_info.arg_env a with + | Some e -> env_info_subst ~subst e id + | None -> subst id + end +| id -> subst id + +let term_info_subst ei = function +| "tname" -> Some (strf "$(b,%s)" @@ term_name (Cmdliner_info.eval_term ei)) +| "mname" -> Some (strf "$(b,%s)" @@ term_name (Cmdliner_info.eval_main ei)) +| _ -> None + +(* Command docs *) + +let invocation ?(sep = ' ') ei = match Cmdliner_info.eval_kind ei with +| `Simple | `Multiple_main -> term_name (Cmdliner_info.eval_main ei) +| `Multiple_sub -> + strf "%s%c%s" + Cmdliner_info.(term_name @@ eval_main ei) sep + Cmdliner_info.(term_name @@ eval_term ei) + +let plain_invocation ei = invocation ei +let invocation ?sep ei = esc @@ invocation ?sep ei + +let synopsis_pos_arg a = + let v = match Cmdliner_info.arg_docv a with "" -> "ARG" | v -> v in + let v = strf "$(i,%s)" (esc v) in + let v = (if Cmdliner_info.arg_is_req a then strf "%s" else strf "[%s]") v in + match Cmdliner_info.(pos_len @@ arg_pos 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 ei = match Cmdliner_info.eval_kind ei with +| `Multiple_main -> strf "$(b,%s) $(i,COMMAND) ..." @@ invocation ei +| `Simple | `Multiple_sub -> + let rev_cli_order (a0, _) (a1, _) = + Cmdliner_info.rev_arg_pos_cli_order a0 a1 + in + let add_pos a acc = match Cmdliner_info.arg_is_opt a with + | true -> acc + | false -> (a, synopsis_pos_arg a) :: acc + in + let args = Cmdliner_info.(term_args @@ eval_term ei) in + let pargs = Cmdliner_info.Args.fold add_pos args [] in + let pargs = List.sort rev_cli_order pargs in + let pargs = String.concat " " (List.rev_map snd pargs) in + strf "$(b,%s) [$(i,OPTION)]... %s" (invocation ei) pargs + +let cmd_docs ei = match Cmdliner_info.eval_kind ei with +| `Simple | `Multiple_sub -> [] +| `Multiple_main -> + let add_cmd acc t = + let cmd = strf "$(b,%s)" @@ term_name t in + (Cmdliner_info.term_docs t, `I (cmd, Cmdliner_info.term_doc t)) :: 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 [] (Cmdliner_info.eval_choices ei) 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 = + if Cmdliner_info.arg_is_pos a + then strf "$(i,%s)" (esc @@ Cmdliner_info.arg_docv a) else + let fmt_name var = match Cmdliner_info.arg_opt_kind a with + | Cmdliner_info.Flag -> fun n -> strf "$(b,%s)" (esc n) + | Cmdliner_info.Opt -> + fun n -> + 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_info.Opt_vopt _ -> + fun n -> + 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) + in + let var = match Cmdliner_info.arg_docv a with "" -> "VAL" | v -> v in + let names = List.sort compare (Cmdliner_info.arg_opt_names a) in + let s = String.concat ", " (List.rev_map (fmt_name var) names) in + s + +let arg_to_man_item ~errs ~subst ~buf a = + let or_env ~value a = match Cmdliner_info.arg_env a with + | None -> "" + | Some e -> + let value = if value then " or" else "absent " in + strf "%s $(b,%s) env" value (esc @@ Cmdliner_info.env_var e) + in + let absent = match Cmdliner_info.arg_absent a with + | Cmdliner_info.Err -> "required" + | Cmdliner_info.Val v -> + match Lazy.force v with + | "" -> strf "%s" (or_env ~value:false a) + | v -> strf "absent=%s%s" v (or_env ~value:true a) + in + let optvopt = match Cmdliner_info.arg_opt_kind a with + | Cmdliner_info.Opt_vopt v -> strf "default=%s" v + | _ -> "" + in + let argvdoc = match optvopt, absent with + | "", "" -> "" + | s, "" | "", s -> strf " (%s)" s + | s, s' -> strf " (%s) (%s)" s s' + in + let subst = arg_info_subst ~subst a in + let doc = Cmdliner_info.arg_doc a in + let doc = Cmdliner_manpage.subst_vars ~errs ~subst buf doc in + (Cmdliner_info.arg_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_info.arg_docs a0) (Cmdliner_info.arg_docs a1) in + if c <> 0 then c else + match Cmdliner_info.arg_is_opt a0, Cmdliner_info.arg_is_opt a1 with + | true, true -> (* optional by name *) + let key names = + let k = List.hd (List.sort rev_compare names) in + let k = Cmdliner_base.lowercase k in + if k.[1] = '-' then String.sub k 1 (String.length k - 1) else k + in + compare + (key @@ Cmdliner_info.arg_opt_names a0) + (key @@ Cmdliner_info.arg_opt_names a1) + | false, false -> (* positional by variable *) + compare + (Cmdliner_base.lowercase @@ Cmdliner_info.arg_docv a0) + (Cmdliner_base.lowercase @@ Cmdliner_info.arg_docv a1) + | true, false -> -1 (* positional first *) + | false, true -> 1 (* optional after *) + in + let keep_arg a acc = + if not Cmdliner_info.(arg_is_pos a && (arg_docv a = "" || arg_doc a = "")) + then (a :: acc) else acc + in + let args = Cmdliner_info.(term_args @@ eval_term ei) in + let args = Cmdliner_info.Args.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 e = + let subst = exit_info_subst ~subst e in + let min, max = Cmdliner_info.exit_statuses e in + let doc = Cmdliner_info.exit_doc e 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_info.(exit_docs e, item) :: acc + in + let exits = Cmdliner_info.(term_exits @@ eval_term ei) in + let exits = List.sort Cmdliner_info.exit_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_info.Envs.mem e seen then acc else + let seen = Cmdliner_info.Envs.add e seen in + let var = strf "$(b,%s)" @@ esc (Cmdliner_info.env_var e) in + let doc = Cmdliner_info.env_doc e in + let doc = Cmdliner_manpage.subst_vars ~errs ~subst buf doc in + let envs = (Cmdliner_info.env_docs e, `I (var, doc)) :: envs in + seen, envs + in + let add_arg_env a acc = match Cmdliner_info.arg_env a with + | None -> acc + | Some e -> add_env_item ~subst:(arg_info_subst ~subst a) acc e + in + let add_env acc e = add_env_item ~subst:(env_info_subst ~subst e) 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_info.(term_args @@ eval_term ei) in + let tenvs = Cmdliner_info.(term_envs @@ eval_term ei) in + let init = Cmdliner_info.Envs.empty, [] in + let acc = Cmdliner_info.Args.fold add_arg_env 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_info.(term_name @@ eval_main ei) in + let to_xref = function + | `Main -> main, 1 + | `Tool tool -> tool, 1 + | `Page (name, sec) -> name, sec + | `Cmd c -> + if Cmdliner_info.eval_has_choice ei c then strf "%s-%s" main c, 1 else + (Format.fprintf errs "xref %s: no such term name@." c; "doc-err", 0) + in + let xref_str (name, sec) = strf "%s(%d)" (esc name) sec in + let xrefs = Cmdliner_info.(term_man_xrefs @@ eval_term ei) 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 s_name) then sm else + let tname = invocation ~sep:'-' ei in + let tdoc = Cmdliner_info.(term_doc @@ eval_term ei) 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 synopsis = `P (synopsis ei) in + Cmdliner_manpage.(smap_append_block sm ~sec:s_synopsis synopsis) + +let insert_term_man_docs ~errs ei sm = + let buf = Buffer.create 200 in + let subst = term_info_subst ei in + let ins sm (s, b) = Cmdliner_manpage.smap_append_block sm s b in + let has_senv = Cmdliner_manpage.(smap_has_section sm s_environment) in + let has_sexit = Cmdliner_manpage.(smap_has_section sm 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_info.(term_man @@ eval_term 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_term_man_docs ei ~errs sm in + Cmdliner_manpage.smap_to_blocks sm + +let title ei = + let main = Cmdliner_info.eval_main ei in + let exec = Cmdliner_base.capitalize (Cmdliner_info.term_name main) in + let name = Cmdliner_base.uppercase (invocation ~sep:'-' ei) in + let center_header = esc @@ strf "%s Manual" exec in + let left_footer = + let version = match Cmdliner_info.term_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 ~errs fmt ppf ei = + Cmdliner_manpage.print + ~errs ~subst:(term_info_subst ei) fmt ppf (man ~errs ei) + +(* Plain synopsis for usage *) + +let pp_plain_synopsis ~errs ppf ei = + let buf = Buffer.create 100 in + let subst = term_info_subst ei in + let syn = Cmdliner_manpage.doc_to_plain ~errs ~subst buf (synopsis ei) in + Format.fprintf ppf "@[%s@]" syn + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_docgen.mli b/src/cmdliner_docgen.mli new file mode 100644 index 0000000..8a457a9 --- /dev/null +++ b/src/cmdliner_docgen.mli @@ -0,0 +1,30 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +val plain_invocation : Cmdliner_info.eval -> string + +val pp_man : + errs:Format.formatter -> Cmdliner_manpage.format -> Format.formatter -> + Cmdliner_info.eval -> unit + +val pp_plain_synopsis : + errs:Format.formatter -> Format.formatter -> Cmdliner_info.eval -> unit + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_info.ml b/src/cmdliner_info.ml new file mode 100644 index 0000000..9a4028d --- /dev/null +++ b/src/cmdliner_info.ml @@ -0,0 +1,233 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + + +let new_id = (* thread-safe UIDs, Oo.id (object end) was used before. *) + let c = ref 0 in + fun () -> + let id = !c in + incr c; if id > !c then assert false (* too many ids *) else id + +(* Environments *) + +type env = (* information about an environment variable. *) + { env_id : int; (* unique id for the env var. *) + env_var : string; (* the variable. *) + env_doc : string; (* help. *) + env_docs : string; } (* title of help section where listed. *) + +let env + ?docs:(env_docs = Cmdliner_manpage.s_environment) + ?doc:(env_doc = "See option $(opt).") env_var = + { env_id = new_id (); env_var; env_doc; env_docs } + +let env_var e = e.env_var +let env_doc e = e.env_doc +let env_docs e = e.env_docs + + +module Env = struct + type t = env + let compare a0 a1 = (compare : int -> int -> int) a0.env_id a1.env_id +end + +module Envs = Set.Make (Env) +type envs = Envs.t + +(* Arguments *) + +type arg_absence = Err | Val of string Lazy.t +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 + +type arg = (* information about a command line argument. *) + { id : int; (* unique id for the argument. *) + absent : arg_absence; (* behaviour if absent. *) + env : env option; (* environment variable. *) + doc : string; (* help. *) + docv : string; (* variable name for the argument in help. *) + 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 dumb_pos = pos ~rev:false ~start:(-1) ~len:None + +let arg ?docs ?(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 = new_id (); absent = Val (lazy ""); env; doc; docv; docs; + pos = dumb_pos; opt_kind = Flag; opt_names; opt_all = false; } + +let arg_id a = a.id +let arg_absent a = a.absent +let arg_env a = a.env +let arg_doc a = a.doc +let arg_docv a = a.docv +let arg_docs a = a.docs +let arg_pos a = a.pos +let arg_opt_kind a = a.opt_kind +let arg_opt_names a = a.opt_names +let arg_opt_all a = a.opt_all +let arg_opt_name_sample a = + (* 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 a.opt_names + | n :: ns -> if (String.length n) > 2 then n else find ns + in + find a.opt_names + +let arg_make_req a = { a with absent = Err } +let arg_make_all_opts a = { a with opt_all = true } +let arg_make_opt ~absent ~kind:opt_kind a = { a with absent; opt_kind } +let arg_make_opt_all ~absent ~kind:opt_kind a = + { a with absent; opt_kind; opt_all = true } + +let arg_make_pos ~pos a = { a with pos } +let arg_make_pos_abs ~absent ~pos a = { a with absent; pos } + +let arg_is_opt a = a.opt_names <> [] +let arg_is_pos a = a.opt_names = [] +let arg_is_req a = a.absent = Err + +let arg_pos_cli_order a0 a1 = (* best-effort order on the cli. *) + let c = compare (a0.pos.pos_rev) (a1.pos.pos_rev) in + if c <> 0 then c else + if a0.pos.pos_rev + then compare a1.pos.pos_start a0.pos.pos_start + else compare a0.pos.pos_start a1.pos.pos_start + +let rev_arg_pos_cli_order a0 a1 = arg_pos_cli_order a1 a0 + +module Arg = struct + type t = arg + let compare a0 a1 = (compare : int -> int -> int) a0.id a1.id +end + +module Args = Set.Make (Arg) +type args = Args.t + +(* Exit info *) + +type exit = + { exit_statuses : int * int; + exit_doc : string; + exit_docs : string; } + +let exit + ?docs:(exit_docs = Cmdliner_manpage.s_exit_status) + ?doc:(exit_doc = "undocumented") ?max min = + let max = match max with None -> min | Some max -> max in + { exit_statuses = (min, max); exit_doc; exit_docs } + +let exit_statuses e = e.exit_statuses +let exit_doc e = e.exit_doc +let exit_docs e = e.exit_docs +let exit_order e0 e1 = compare e0.exit_statuses e1.exit_statuses + +(* Term info *) + +type term_info = + { term_name : string; (* name of the term. *) + term_version : string option; (* version (for --version). *) + term_doc : string; (* one line description of term. *) + term_docs : string; (* title of man section where listed (commands). *) + term_sdocs : string; (* standard options, title of section where listed. *) + term_exits : exit list; (* exit codes for the term. *) + term_envs : env list; (* env vars that influence the term. *) + term_man : Cmdliner_manpage.block list; (* man page text. *) + term_man_xrefs : Cmdliner_manpage.xref list; } (* man cross-refs. *) + +type term = + { term_info : term_info; + term_args : args; } + +let term + ?args:(term_args = Args.empty) ?man_xrefs:(term_man_xrefs = []) + ?man:(term_man = []) ?envs:(term_envs = []) ?exits:(term_exits = []) + ?sdocs:(term_sdocs = Cmdliner_manpage.s_options) + ?docs:(term_docs = "COMMANDS") ?doc:(term_doc = "") ?version:term_version + term_name = + let term_info = + { term_name; term_version; term_doc; term_docs; term_sdocs; term_exits; + term_envs; term_man; term_man_xrefs } + in + { term_info; term_args } + +let term_name t = t.term_info.term_name +let term_version t = t.term_info.term_version +let term_doc t = t.term_info.term_doc +let term_docs t = t.term_info.term_docs +let term_stdopts_docs t = t.term_info.term_sdocs +let term_exits t = t.term_info.term_exits +let term_envs t = t.term_info.term_envs +let term_man t = t.term_info.term_man +let term_man_xrefs t = t.term_info.term_man_xrefs +let term_args t = t.term_args + +let term_add_args t args = + { t with term_args = Args.union args t.term_args } + +(* Eval info *) + +type eval = (* information about the evaluation context. *) + { term : term; (* term being evaluated. *) + main : term; (* main term. *) + choices : term list; (* all term choices. *) + env : string -> string option } (* environment variable lookup. *) + +let eval ~term ~main ~choices ~env = { term; main; choices; env } +let eval_term e = e.term +let eval_main e = e.main +let eval_choices e = e.choices +let eval_env_var e v = e.env v + +let eval_kind ei = + if ei.choices = [] then `Simple else + if (ei.term.term_info.term_name == ei.main.term_info.term_name) + then `Multiple_main else `Multiple_sub + +let eval_with_term ei term = { ei with term } + +let eval_has_choice e cmd = + let is_cmd t = t.term_info.term_name = cmd in + List.exists is_cmd e.choices + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_info.mli b/src/cmdliner_info.mli new file mode 100644 index 0000000..a743665 --- /dev/null +++ b/src/cmdliner_info.mli @@ -0,0 +1,140 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +(** Terms, argument, env vars information. + + The following types keep untyped information about arguments and + terms. This data is used to parse the command line, report errors + and format man pages. *) + +(** {1:env Environment variables} *) + +type env +val env : ?docs:string -> ?doc:string -> string -> env +val env_var : env -> string +val env_doc : env -> string +val env_docs : env -> string + +module Env : Set.OrderedType with type t = env +module Envs : Set.S with type elt = env +type envs = Envs.t + +(** {1:arg Arguments} *) + +type arg_absence = +| Err (** an error is reported. *) +| Val of string Lazy.t (** if <> "", takes the given default value. *) +(** 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 arg +val arg : + ?docs:string -> ?docv:string -> ?doc:string -> ?env:env -> + string list -> arg + +val arg_id : arg -> int +val arg_absent : arg -> arg_absence +val arg_env : arg -> env option +val arg_doc : arg -> string +val arg_docv : arg -> string +val arg_docs : arg -> string +val arg_opt_names : arg -> string list (* has dashes *) +val arg_opt_name_sample : arg -> string (* warning must be an opt arg *) +val arg_opt_kind : arg -> opt_kind +val arg_pos : arg -> pos_kind + +val arg_make_req : arg -> arg +val arg_make_all_opts : arg -> arg +val arg_make_opt : absent:arg_absence -> kind:opt_kind -> arg -> arg +val arg_make_opt_all : absent:arg_absence -> kind:opt_kind -> arg -> arg +val arg_make_pos : pos:pos_kind -> arg -> arg +val arg_make_pos_abs : absent:arg_absence -> pos:pos_kind -> arg -> arg + +val arg_is_opt : arg -> bool +val arg_is_pos : arg -> bool +val arg_is_req : arg -> bool + +val arg_pos_cli_order : arg -> arg -> int +val rev_arg_pos_cli_order : arg -> arg -> int + +module Arg : Set.OrderedType with type t = arg +module Args : Set.S with type elt = arg +type args = Args.t + +(** {1:exit Exit status} *) + +type exit +val exit : ?docs:string -> ?doc:string -> ?max:int -> int -> exit +val exit_statuses : exit -> int * int +val exit_doc : exit -> string +val exit_docs : exit -> string +val exit_order : exit -> exit -> int + +(** {1:term Term information} *) + +type term + +val term : + ?args:args -> ?man_xrefs:Cmdliner_manpage.xref list -> + ?man:Cmdliner_manpage.block list -> ?envs:env list -> ?exits:exit list -> + ?sdocs:string -> ?docs:string -> ?doc:string -> ?version:string -> + string -> term + +val term_name : term -> string +val term_version : term -> string option +val term_doc : term -> string +val term_docs : term -> string +val term_stdopts_docs : term -> string +val term_exits : term -> exit list +val term_envs : term -> env list +val term_man : term -> Cmdliner_manpage.block list +val term_man_xrefs : term -> Cmdliner_manpage.xref list +val term_args : term -> args + +val term_add_args : term -> args -> term + +(** {1:eval Evaluation information} *) + +type eval + +val eval : + term:term -> main:term -> choices:term list -> + env:(string -> string option) -> eval + +val eval_term : eval -> term +val eval_main : eval -> term +val eval_choices : eval -> term list +val eval_env_var : eval -> string -> string option +val eval_kind : eval -> [> `Multiple_main | `Multiple_sub | `Simple ] +val eval_with_term : eval -> term -> eval +val eval_has_choice : eval -> string -> bool + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_manpage.ml b/src/cmdliner_manpage.ml new file mode 100644 index 0000000..d627831 --- /dev/null +++ b/src/cmdliner_manpage.ml @@ -0,0 +1,504 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +open Result + +(* Manpages *) + +type block = + [ `S of string | `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 "$(tname) exits with the following status:" + +let s_environment = "ENVIRONMENT" +let s_environment_intro = + `P "These environment variables affect the execution of $(tname):" + +let s_files = "FILES" +let s_examples = "EXAMPLES" +let s_bugs = "BUGS" +let s_authors = "AUTHORS" +let s_see_also = "SEE ALSO" + +(* 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; |] + +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 + | (s, (_, rbs)) :: smap -> loop acc smap s rbs + | [] -> acc + in + match smap with + | [] -> [] + | (s, (_, rbs)) :: smap -> loop [] smap s rbs + +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 +let pf = Format.fprintf +let pp_str = Format.pp_print_string +let pp_char = Format.pp_print_char +let pp_indent ppf c = for i = 1 to c do pp_char ppf ' ' done +let pp_lines = Cmdliner_base.pp_lines +let pp_tokens = Cmdliner_base.pp_tokens + +(* Cmdliner markup handling *) + +let err e 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 ~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 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 + if not (is_markup_dir markup) + then (err_markup ~errs markup s; loop start next) else + let start_data = min + 1 in + (flush start (i - 1); + add_markup_text ~errs loop b s start_data need_escape escape) + | _ -> + 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 ~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 = pp_tokens ~spaces:true ppf t in + let rec loop = function + | [] -> () + | t :: ts -> + begin match t with + | `Noblank -> () + | `Blocks bs -> loop bs (* not T.R. *) + | `P s -> pf ppf "%a@[%a@]@," pp_indent p_indent pp_tokens (markup s) + | `S s -> pf ppf "@[%a@]" pp_tokens (markup s) + | `Pre s -> pf ppf "%a@[%a@]@," pp_indent p_indent pp_lines (markup s) + | `I (label, s) -> + let label = markup label in + let s = markup s in + pf ppf "@[%a@[%a@]" pp_indent p_indent pp_tokens label; + if s = "" then pf ppf "@]@," else + let ll = String.length label in + begin match ll < l_indent with + | true -> + pf ppf "%a@[%a@]@]" pp_indent (l_indent - ll) pp_tokens s + | false -> + pf ppf "@\n%a@[%a@]@]" + pp_indent (p_indent + l_indent) pp_tokens s + end; + match ts with `I _ :: _ -> pf ppf "@," | _ -> () + end; + begin match ts with + | `Noblank :: ts -> loop ts + | ts -> Format.pp_print_cut ppf (); loop ts + end + in + loop ts + +let pp_plain_page ~errs subst ppf (_, text) = + pf ppf "@[%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 = pp_tokens ~spaces:false ppf t in + let rec pp_block = function + | `Blocks bs -> List.iter pp_block bs (* not T.R. *) + | `P s -> pf ppf "@\n.P@\n%a" pp_tokens (markup s) + | `Pre s -> pf ppf "@\n.P@\n.nf@\n%a@\n.fi" pp_lines (markup s) + | `S s -> pf ppf "@\n.SH %a" pp_tokens (markup s) + | `Noblank -> pf ppf "@\n.sp -1" + | `I (l, s) -> + 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) = + pf ppf ".\\\" Pipe this output to groff -Tutf8 | less@\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 find_cmd cmds = + let test, null = match Sys.os_type with + | "Win32" -> "where", " NUL" + | _ -> "type", "/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 pp_to_pager print ppf v = + let pager = + let cmds = ["less"; "more"] in + let cmds = try (Sys.getenv "PAGER") :: cmds with Not_found -> cmds in + let cmds = try (Sys.getenv "MANPAGER") :: cmds with Not_found -> cmds in + find_cmd cmds + in + match pager with + | None -> print `Plain ppf v + | Some pager -> + let cmd = match (find_cmd ["groff"; "nroff"]) with + | None -> + begin match pp_to_temp_file (print `Plain) v with + | None -> None + | Some f -> Some (strf "%s < %s" pager f) + end + | Some c -> + begin match pp_to_temp_file (print `Groff) v with + | None -> None + | Some f -> + (* TODO use -Tutf8, but annoyingly maps U+002D to U+2212. *) + let xroff = if c = "groff" then c ^ " -Tascii -P-c" else c in + Some (strf "%s < %s | %s" xroff 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 format = [ `Auto | `Pager | `Plain | `Groff ] + +let rec print + ?(errs = Format.err_formatter) + ?(subst = fun x -> None) fmt ppf page = + match fmt with + | `Pager -> pp_to_pager (print ~errs ~subst) ppf page + | `Plain -> pp_plain_page ~errs subst ppf page + | `Groff -> pp_groff_page ~errs subst ppf page + | `Auto -> + match try (Some (Sys.getenv "TERM")) with Not_found -> None with + | None | Some "dumb" -> print ~errs ~subst `Plain ppf page + | Some _ -> print ~errs ~subst `Pager ppf page + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_manpage.mli b/src/cmdliner_manpage.mli new file mode 100644 index 0000000..f44a2f9 --- /dev/null +++ b/src/cmdliner_manpage.mli @@ -0,0 +1,100 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +(** Manpages. + + See {!Cmdliner.Manpage}. *) + +type block = + [ `S of string | `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 : string +val s_synopsis : string +val s_description : string +val s_commands : string +val s_arguments : string +val s_options : string +val s_common_options : string +val s_exit_status : string +val s_environment : string +val s_files : string +val s_bugs : string +val s_examples : string +val s_authors : string +val s_see_also : string + +(** {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:string -> bool +val smap_append_block : smap -> sec:string -> 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 format = [ `Auto | `Pager | `Plain | `Groff ] +val print : + ?errs:Format.formatter -> ?subst:(string -> string option) -> format -> + Format.formatter -> t -> unit + +(** {1 Printers and escapes used by Cmdliner module} *) + +val subst_vars : + errs:Format.formatter -> subst:(string -> string option) -> 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:(string -> string option) -> Buffer.t -> + string -> string +(** [doc_to_plain b ~subst s] using [b], subsitutes in [s] variables by + their [subst] definition and renders cmdliner directives to plain + text. + + @raise Invalid_argument in case of illegal syntax. *) + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_msg.ml b/src/cmdliner_msg.ml new file mode 100644 index 0000000..a657eaa --- /dev/null +++ b/src/cmdliner_msg.ml @@ -0,0 +1,115 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +let strf = Printf.sprintf +let quote = Cmdliner_base.quote + +let pp = Format.fprintf +let pp_text = Cmdliner_base.pp_text +let pp_lines = Cmdliner_base.pp_lines + +(* Environment variable errors *) + +let err_env_parse env ~err = + let var = Cmdliner_info.env_var env in + strf "environment variable %s: %s" (quote var) err + +(* Positional argument errors *) + +let err_pos_excess excess = + strf "too many arguments, don't know what to do with %s" + (String.concat ", " (List.map quote excess)) + +let err_pos_miss a = match Cmdliner_info.arg_docv a with +| "" -> "a required argument is missing" +| v -> strf "required argument %s is missing" v + +let err_pos_misses = function +| [] -> assert false +| [a] -> err_pos_miss a +| args -> + let add_arg acc a = match Cmdliner_info.arg_docv a with + | "" -> "ARG" :: acc + | argv -> argv :: acc + in + let rev_args = List.sort Cmdliner_info.rev_arg_pos_cli_order args in + let args = List.fold_left add_arg [] rev_args in + let args = String.concat ", " args in + strf "required arguments %s are missing" args + +let err_pos_parse a ~err = match Cmdliner_info.arg_docv a with +| "" -> err +| argv -> + match Cmdliner_info.(pos_len @@ arg_pos a) with + | Some 1 -> strf "%s argument: %s" argv err + | None | Some _ -> strf "%s... arguments: %s" argv err + +(* Optional argument errors *) + +let err_flag_value flag v = + strf "option %s is a flag, it cannot take the argument %s" + (quote flag) (quote v) + +let err_opt_value_missing f = strf "option %s needs an argument" (quote f) +let err_opt_parse f ~err = strf "option %s: %s" (quote f) err +let err_opt_repeated f f' = + if f = f' then strf "option %s cannot be repeated" (quote f) else + strf "options %s and %s cannot be present at the same time" + (quote f) (quote f') + +(* Argument errors *) + +let err_arg_missing a = + if Cmdliner_info.arg_is_pos a then err_pos_miss a else + strf "required option %s is missing" (Cmdliner_info.arg_opt_name_sample a) + +(* Other messages *) + +let exec_name ei = Cmdliner_info.(term_name @@ eval_main ei) + +let pp_version ppf ei = match Cmdliner_info.(term_version @@ eval_main ei) with +| None -> assert false +| Some v -> pp ppf "@[%a@]@." Cmdliner_base.pp_text v + +let pp_try_help ppf ei = match Cmdliner_info.eval_kind ei with +| `Simple | `Multiple_main -> + pp ppf "@[<2>Try `%s --help' for more information.@]" (exec_name ei) +| `Multiple_sub -> + let exec_cmd = Cmdliner_docgen.plain_invocation ei in + pp ppf "@[<2>Try `%s --help' or `%s --help' for more information.@]" + exec_cmd (exec_name ei) + +let pp_err ppf ei ~err = pp ppf "%s: @[%a@]@." (exec_name ei) pp_text err + +let pp_err_usage ppf ei ~err = + pp ppf "@[%s: @[%a@]@,@[Usage: @[%a@]@]@,%a@]@." + (exec_name ei) pp_text err (Cmdliner_docgen.pp_plain_synopsis ~errs:ppf) ei + pp_try_help ei + +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 + pp ppf "%s: @[internal error, uncaught exception:@\n%a@]@." + (exec_name ei) pp_lines (strf "%s\n%s" (Printexc.to_string e) bt) + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_msg.mli b/src/cmdliner_msg.mli new file mode 100644 index 0000000..141a4b5 --- /dev/null +++ b/src/cmdliner_msg.mli @@ -0,0 +1,54 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +(** Messages for the end-user. *) + +(** {1:env_err Environment variable errors} *) + +val err_env_parse : Cmdliner_info.env -> err:string -> string + +(** {1:pos_err Positional argument errors} *) + +val err_pos_excess : string list -> string +val err_pos_misses : Cmdliner_info.arg list -> string +val err_pos_parse : Cmdliner_info.arg -> 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_info.arg -> string + +(** {1:msgs Other messages} *) + +val pp_version : Format.formatter -> Cmdliner_info.eval -> unit +val pp_try_help : Format.formatter -> Cmdliner_info.eval -> unit +val pp_err : Format.formatter -> Cmdliner_info.eval -> err:string -> unit +val pp_err_usage : Format.formatter -> Cmdliner_info.eval -> err:string -> unit +val pp_backtrace : + Format.formatter -> + Cmdliner_info.eval -> exn -> Printexc.raw_backtrace -> unit + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_suggest.ml b/src/cmdliner_suggest.ml new file mode 100644 index 0000000..33b35ef --- /dev/null +++ b/src/cmdliner_suggest.ml @@ -0,0 +1,54 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +let levenshtein_distance s t = + (* As found here http://rosettacode.org/wiki/Levenshtein_distance#OCaml *) + let minimum a b c = min a (min b c) in + let m = String.length s in + let n = String.length t in + (* for all i and j, d.(i).(j) will hold the Levenshtein distance between + the first i characters of s and the first j characters of t *) + let d = Array.make_matrix (m+1) (n+1) 0 in + for i = 0 to m do d.(i).(0) <- i done; + for j = 0 to n do d.(0).(j) <- j done; + for j = 1 to n do + for i = 1 to m do + if s.[i-1] = t.[j-1] then + d.(i).(j) <- d.(i-1).(j-1) (* no operation required *) + else + d.(i).(j) <- minimum + (d.(i-1).(j) + 1) (* a deletion *) + (d.(i).(j-1) + 1) (* an insertion *) + (d.(i-1).(j-1) + 1) (* a substitution *) + done; + done; + d.(m).(n) + +let value s candidates = + let add (min, acc) name = + let d = levenshtein_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 [] + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_suggest.mli b/src/cmdliner_suggest.mli new file mode 100644 index 0000000..50b8378 --- /dev/null +++ b/src/cmdliner_suggest.mli @@ -0,0 +1,25 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +val value : string -> string list -> string list +(** [value near candidates] suggests values from [candidates] + not to far from near. *) + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_term.ml b/src/cmdliner_term.ml new file mode 100644 index 0000000..6f22b71 --- /dev/null +++ b/src/cmdliner_term.ml @@ -0,0 +1,43 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +open Result + +type term_escape = + [ `Error of bool * string + | `Help of Cmdliner_manpage.format * string option ] + +type 'a parser = + Cmdliner_info.eval -> Cmdliner_cline.t -> + ('a, [ `Parse of string | term_escape ]) result + +type 'a t = Cmdliner_info.args * 'a parser + +let const v = Cmdliner_info.Args.empty, (fun _ _ -> Ok v) +let app (args_f, f) (args_v, v) = + Cmdliner_info.Args.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) + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_term.mli b/src/cmdliner_term.mli new file mode 100644 index 0000000..bfd2887 --- /dev/null +++ b/src/cmdliner_term.mli @@ -0,0 +1,42 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +open Result + +(** Terms *) + +type term_escape = + [ `Error of bool * string + | `Help of Cmdliner_manpage.format * string option ] + +type 'a parser = + Cmdliner_info.eval -> Cmdliner_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 = Cmdliner_info.args * 'a parser +(** The type for terms. The list of arguments it can parse and the parsing + function that does so. *) + +val const : 'a -> 'a t +val app : ('a -> 'b) t -> 'a t -> 'b t + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_trie.ml b/src/cmdliner_trie.ml new file mode 100644 index 0000000..018713f --- /dev/null +++ b/src/cmdliner_trie.ml @@ -0,0 +1,97 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +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 t k = + try match (find_node t k).v with + | Key v | Pre v -> `Ok v | Amb -> `Ambiguous | Nil -> `Not_found + with Not_found -> `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 + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_trie.mli b/src/cmdliner_trie.mli new file mode 100644 index 0000000..903d58d --- /dev/null +++ b/src/cmdliner_trie.mli @@ -0,0 +1,35 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + cmdliner v1.0.2 + ---------------------------------------------------------------------------*) + +(** 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 : 'a t -> string -> [ `Ok of 'a | `Ambiguous | `Not_found ] +val ambiguities : 'a t -> string -> string list +val of_list : (string * 'a) list -> 'a t + +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli + + 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. + ---------------------------------------------------------------------------*) diff --git a/test/chorus.ml b/test/chorus.ml new file mode 100644 index 0000000..66cbfdf --- /dev/null +++ b/test/chorus.ml @@ -0,0 +1,31 @@ +(* Example from the documentation, this code is in public domain. *) + +(* Implementation of the command *) + +let chorus count msg = for i = 1 to count do print_endline msg done + +(* Command line interface *) + +open Cmdliner + +let count = + let doc = "Repeat the message $(docv) times." in + Arg.(value & opt int 10 & info ["c"; "count"] ~docv:"COUNT" ~doc) + +let msg = + let doc = "Overrides the default message to print." in + let env = Arg.env_var "CHORUS_MSG" ~doc in + let doc = "The message to print." in + Arg.(value & pos 0 string "Revolt!" & info [] ~env ~docv:"MSG" ~doc) + +let chorus_t = Term.(const chorus $ count $ msg) + +let info = + let doc = "print a customizable message repeatedly" in + let man = [ + `S Manpage.s_bugs; + `P "Email bug reports to ." ] + in + Term.info "chorus" ~version:"v1.0.2" ~doc ~exits:Term.default_exits ~man + +let () = Term.exit @@ Term.eval (chorus_t, info) diff --git a/test/cp_ex.ml b/test/cp_ex.ml new file mode 100644 index 0000000..19dc4b1 --- /dev/null +++ b/test/cp_ex.ml @@ -0,0 +1,54 @@ +(* Example from the documentation, this code is in public domain. *) + +(* Implementation, we check the dest argument and print the args *) + +let cp verbose recurse force srcs dest = + if List.length srcs > 1 && + (not (Sys.file_exists dest) || not (Sys.is_directory dest)) + then + `Error (false, dest ^ " is 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 + +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 cmd = + let doc = "copy files" in + let man_xrefs = + [ `Tool "mv"; `Tool "scp"; `Page ("umask", 2); `Page ("symlink", 7) ] + in + let exits = Term.default_exits in + let man = + [ `S Manpage.s_bugs; + `P "Email them to ."; ] + in + Term.(ret (const cp $ verbose $ recurse $ force $ srcs $ dest)), + Term.info "cp" ~version:"v1.0.2" ~doc ~exits ~man ~man_xrefs + +let () = Term.(exit @@ eval cmd) diff --git a/test/darcs_ex.ml b/test/darcs_ex.ml new file mode 100644 index 0000000..2404b50 --- /dev/null +++ b/test/darcs_ex.ml @@ -0,0 +1,149 @@ +(* Example from the documentation, this code is in public domain. *) + +(* 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 + match conv 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 + +(* 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 `$(mname) $(i,COMMAND) --help' for help on a single command.";`Noblank; + `P "Use `$(mname) help patterns' for help on patch matching."; `Noblank; + `P "Use `$(mname) 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 $(mname) command." in + Arg.(value & opt (some string) None & info ["prehook"] ~docs ~doc) + in + Term.(const copts $ debug $ verb $ prehook) + +(* Commands *) + +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 exits = Term.default_exits 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 + Term.(const initialize $ copts_t $ repodir), + Term.info "initialize" ~doc ~sdocs:Manpage.s_common_options ~exits ~man + +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 exits = Term.default_exits 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 + Term.(const record $ copts_t $ pname $ author $ all $ ask_deps $ files), + Term.info "record" ~doc ~sdocs:Manpage.s_common_options ~exits ~man + +let help_cmd = + let topic = + let doc = "The topic to get help on. `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 exits = Term.default_exits in + let man = + [`S Manpage.s_description; + `P "Prints help about darcs commands and other subjects..."; + `Blocks help_secs; ] + in + Term.(ret (const help $ copts_t $ Arg.man_format $ Term.choice_names $topic)), + Term.info "help" ~doc ~exits ~man + +let default_cmd = + let doc = "a revision control system" in + let sdocs = Manpage.s_common_options in + let exits = Term.default_exits in + let man = help_secs in + Term.(ret (const (fun _ -> `Help (`Pager, None)) $ copts_t)), + Term.info "darcs" ~version:"v1.0.2" ~doc ~sdocs ~exits ~man + +let cmds = [initialize_cmd; record_cmd; help_cmd] + +let () = Term.(exit @@ eval_choice default_cmd cmds) diff --git a/test/revolt.ml b/test/revolt.ml new file mode 100644 index 0000000..f372e1d --- /dev/null +++ b/test/revolt.ml @@ -0,0 +1,9 @@ +(* Example from the documentation, this code is in public domain. *) + +let revolt () = print_endline "Revolt!" + +open Cmdliner + +let revolt_t = Term.(const revolt $ const ()) + +let () = Term.(exit @@ eval (revolt_t, Term.info "revolt")) diff --git a/test/rm_ex.ml b/test/rm_ex.ml new file mode 100644 index 0000000..0d797f0 --- /dev/null +++ b/test/rm_ex.ml @@ -0,0 +1,53 @@ +(* Example from the documentation, this code is in public domain. *) + +(* 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 + +let files = Arg.(non_empty & pos_all file [] & info [] ~docv:"FILE") +let prompt = + let doc = "Prompt before every removal." in + let always = Always, Arg.info ["i"] ~doc in + let doc = "Ignore nonexistent files and never prompt." in + let never = Never, Arg.info ["f"; "force"] ~doc in + 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 + let once = 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 cmd = + let doc = "remove files or directories" in + let man = [ + `S Manpage.s_description; + `P "$(tname) 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 `-', for example + `-foo', use one of these commands:"; + `Pre "$(mname) -- -foo\n\ + $(mname) ./-foo"; + `P "$(tname) removes symbolic links, not the files referenced by the + links."; + `S Manpage.s_bugs; `P "Report bugs to ."; + `S Manpage.s_see_also; `P "$(b,rmdir)(1), $(b,unlink)(2)" ] + in + Term.(const rm $ prompt $ recursive $ files), + Term.info "rm" ~version:"v1.0.2" ~doc ~exits:Term.default_exits ~man + +let () = Term.(exit @@ eval cmd) diff --git a/test/tail_ex.ml b/test/tail_ex.ml new file mode 100644 index 0000000..932f0bf --- /dev/null +++ b/test/tail_ex.ml @@ -0,0 +1,74 @@ +(* Example from the documentation, this code is in public domain. *) + +(* 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 Result +open Cmdliner + +let lines = + let loc = + let parse 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 (`Msg "unable to parse integer") + in + let print ppf p = Format.fprintf ppf "%s" (loc_str p) in + Arg.conv ~docv:"N" (parse, print) + in + Arg.(value & opt loc (true, 10) & info ["n"; "lines"] ~docv:"N" + ~doc:"Output the last $(docv) lines or use $(i,+)$(docv) to start + output after the $(i,N)-1th line.") +let follow = + let doc = "Output appended data as the file grows. $(docv) specifies how the + file should be tracked, by its `name' or by its `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 doc = "Never output headers giving file names." in + let quiet = Quiet, Arg.info ["q"; "quiet"; "silent"] ~doc in + let doc = "Always output headers giving file names." in + let verbose = 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 cmd = + let doc = "display the last part of a file" in + let man = [ + `S Manpage.s_description; + `P "$(tname) 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 ."; + `S Manpage.s_see_also; + `P "$(b,cat)(1), $(b,head)(1)" ] + in + Term.(const tail $ lines $ follow $ verb $ pid $ files), + Term.info "tail" ~version:"v1.0.2" ~doc ~exits:Term.default_exits ~man + +let () = Term.(exit @@ eval cmd) diff --git a/test/test_man.ml b/test/test_man.ml new file mode 100644 index 0000000..8bab462 --- /dev/null +++ b/test/test_man.ml @@ -0,0 +1,100 @@ + +open Cmdliner + +let hey = + let doc = "Equivalent to set $(opt)." in + let env = Arg.env_var "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 = Arg.env_var "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 = Arg.env_var "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 $(mname) $(tname)" in + let docs = "MIAOUW SECTION (non-standard unpositioned do not do this)" in + let env = Arg.env_var "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. $(mname) is the main term name, $(tname) is the + term name." + 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 = "print a customizable message repeatedly" in + let envs = [ Term.env_info "TEST_IT" ~doc:"This is $(env) for $(tname)" ] in + let exits = [ Term.exit_info ~doc:"This is a $(status) for $(tname)" 1; + Term.exit_info ~doc:"Ranges from $(status) to $(status_max)" + ~max:10 2; ] @ Term.default_exits + in + let man = [ + `S "THIS IS A SECTION FOR $(mname)"; + `P "$(mname) subst at begin and end $(mname)"; + `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 $(mname) 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 aswell $(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 .";] + in + let man_xrefs = [`Page ("ascii", 7); `Main; `Tool "grep";] in + Term.info "man_test" ~version:"v1.0.2" ~doc ~envs ~exits ~man ~man_xrefs + +let () = Term.exit @@ Term.eval (man_test_t, info) diff --git a/test/test_man_utf8.ml b/test/test_man_utf8.ml new file mode 100644 index 0000000..e4112a9 --- /dev/null +++ b/test/test_man_utf8.ml @@ -0,0 +1,11 @@ +open Cmdliner + +let nop () = print_endline "It's the manual that is of interest." + + +let test_pos = + Term.(const nop $ const ()), + Term.info "test_pos" + ~doc:"UTF-8 test: íöüóőúűéáăîâșț ÍÜÓŐÚŰÉÁĂÎÂȘȚ 雙峰駱駝" + +let () = Term.(exit @@ eval test_pos) diff --git a/test/test_opt_req.ml b/test/test_opt_req.ml new file mode 100644 index 0000000..4cb525d --- /dev/null +++ b/test/test_opt_req.ml @@ -0,0 +1,13 @@ +open Cmdliner + +let opt o = print_endline o + +let test_opt = + let req = + Arg.(required & opt (some string) None & info ["r"; "req"] ~docv:"ARG") + in + Term.(const opt $ req), + Term.info "test_opt_req" + ~doc:"Test optional required arguments (don't do this)" + +let () = Term.(exit @@ eval test_opt) diff --git a/test/test_pos.ml b/test/test_pos.ml new file mode 100644 index 0000000..fd6e101 --- /dev/null +++ b/test/test_pos.ml @@ -0,0 +1,13 @@ +open Cmdliner + +let pos l t r = + print_endline (String.concat "\n" (l @ ["--"; t; "--"] @ r)) + +let test_pos = + let l = Arg.(value & pos_left 2 string [] & info [] ~docv:"LEFT") in + let t = Arg.(value & pos 2 string "undefined" & info [] ~docv:"TWO") in + let r = Arg.(value & pos_right 2 string [] & info [] ~docv:"RIGHT") in + Term.(const pos $ l $ t $ r), + Term.info "test_pos" ~doc:"Test pos arguments" + +let () = Term.(exit @@ eval test_pos) diff --git a/test/test_pos_all.ml b/test/test_pos_all.ml new file mode 100644 index 0000000..b5dc708 --- /dev/null +++ b/test/test_pos_all.ml @@ -0,0 +1,11 @@ +open Cmdliner + +let pos_all all = print_endline (String.concat "\n" all) + +let test_pos_all = + let docv = "THEARG" in + let all = Arg.(value & pos_all string [] & info [] ~docv) in + Term.(const pos_all $ all), + Term.info "test_pos_all" ~doc:"Test pos all" + +let () = Term.(exit @@ eval test_pos_all) diff --git a/test/test_pos_left.ml b/test/test_pos_left.ml new file mode 100644 index 0000000..90e4fbe --- /dev/null +++ b/test/test_pos_left.ml @@ -0,0 +1,11 @@ +open Cmdliner + +let pos l = + print_endline (String.concat "\n" l) + +let test_pos_left = + let l = Arg.(value & pos_left 2 string [] & info [] ~docv:"LEFT") in + Term.(const pos $ l), + Term.info "test_pos" ~doc:"Test pos left" + +let () = Term.(exit @@ eval test_pos_left) diff --git a/test/test_pos_req.ml b/test/test_pos_req.ml new file mode 100644 index 0000000..282a77a --- /dev/null +++ b/test/test_pos_req.ml @@ -0,0 +1,15 @@ +open Cmdliner + +let pos r a1 a0 a2 = + print_endline (String.concat "\n" ([a0; a1; a2; "--"] @ r)) + +let test_pos = + let req p = + let docv = Printf.sprintf "ARG%d" p in + Arg.(required & pos p (some string) None & info [] ~docv) + in + let right = Arg.(non_empty & pos_right 2 string [] & info [] ~docv:"RIGHT") in + Term.(const pos $ right $ req 1 $ req 0 $ req 2), + Term.info "test_pos_req" ~doc:"Test pos req arguments" + +let () = Term.(exit @@ eval test_pos) diff --git a/test/test_pos_rev.ml b/test/test_pos_rev.ml new file mode 100644 index 0000000..d8321aa --- /dev/null +++ b/test/test_pos_rev.ml @@ -0,0 +1,14 @@ +open Cmdliner + +let pos l t r = + print_endline (String.concat "\n" (l @ ["--"; t; "--"] @ r)) + +let test_pos = + let rev = true in + let l = Arg.(value & pos_left ~rev 2 string [] & info [] ~docv:"LEFT") in + let t = Arg.(value & pos ~rev 2 string "undefined" & info [] ~docv:"TWO") in + let r = Arg.(value & pos_right ~rev 2 string [] & info [] ~docv:"RIGHT") in + Term.(const pos $ l $ t $ r), + Term.info "test_pos" ~doc:"Test pos rev arguments" + +let () = Term.(exit @@ eval test_pos) diff --git a/test/test_term_dups.ml b/test/test_term_dups.ml new file mode 100644 index 0000000..c646276 --- /dev/null +++ b/test/test_term_dups.ml @@ -0,0 +1,19 @@ +open Cmdliner + +let dups p p_dup o o_dup = + let b = string_of_bool in + print_endline (String.concat "\n" [p; p_dup; b o; b o_dup;]) + +let test_pos = + let p = + let doc = "First pos argument should show up only once in the docs" in + Arg.(value & pos 0 string "undefined" & info [] ~doc ~docv:"POS") + in + let o = + let doc = "This should show up only once in the docs" in + Arg.(value & flag & info ["f"; "flag"] ~doc) + in + Term.(const dups $ p $ p $ o $ o), + Term.info "test_term_dups" ~doc:"Test multiple term usage" + +let () = Term.(exit @@ eval test_pos) -- cgit v1.2.3 From f4282dec39ce069a35c53c6eb58455cd40136472 Mon Sep 17 00:00:00 2001 From: Hendrik Tews Date: Fri, 11 May 2018 15:30:44 +0200 Subject: install without adding execute permissions Gbp-Pq: Name install-x.patch --- Makefile | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/Makefile b/Makefile index 5cbc380..a723fd8 100644 --- a/Makefile +++ b/Makefile @@ -35,7 +35,7 @@ install: $(INSTALL-TARGETS) install-doc: $(INSTALL) -d $(DOCDIR) - $(INSTALL) CHANGES.md LICENSE.md README.md $(DOCDIR) + $(INSTALL) -m 644 CHANGES.md LICENSE.md README.md $(DOCDIR) clean: $(OCAMLBUILD) -clean @@ -53,16 +53,16 @@ create-libdir: $(INSTALL) -d $(LIBDIR) install-common: create-libdir - $(INSTALL) pkg/META opam $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) + $(INSTALL) -m 644 pkg/META opam $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) install-byte: create-libdir - $(INSTALL) $(BASE).cma $(LIBDIR) + $(INSTALL) -m 644 $(BASE).cma $(LIBDIR) install-native: create-libdir - $(INSTALL) $(BASE).cmxa $(BASE).a $(wildcard $(B)/cmdliner*.cmx) $(LIBDIR) + $(INSTALL) -m 644 $(BASE).cmxa $(BASE).a $(wildcard $(B)/cmdliner*.cmx) $(LIBDIR) install-native-dynlink: create-libdir - $(INSTALL) $(BASE).cmxs $(LIBDIR) + $(INSTALL) -m 644 $(BASE).cmxs $(LIBDIR) .PHONY: all install install-doc clean build-byte build-native \ build-native-dynlink create-libdir install-common install-byte \ -- cgit v1.2.3 From f67511440f2f53478042562ed4cd169815a88b06 Mon Sep 17 00:00:00 2001 From: Hendrik Tews Date: Tue, 23 Jul 2019 09:38:37 +0200 Subject: install without adding execute permissions Gbp-Pq: Name install-x.patch --- Makefile | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Makefile b/Makefile index 1d2ffd4..e116b6f 100644 --- a/Makefile +++ b/Makefile @@ -41,7 +41,7 @@ install: $(INSTALL-TARGETS) install-doc: $(INSTALL) -d $(DOCDIR) - $(INSTALL) CHANGES.md LICENSE.md README.md $(DOCDIR) + $(INSTALL) -m 644 CHANGES.md LICENSE.md README.md $(DOCDIR) clean: ocaml build.ml clean @@ -59,18 +59,18 @@ create-libdir: $(INSTALL) -d $(LIBDIR) install-common: create-libdir - $(INSTALL) pkg/META $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) - $(INSTALL) cmdliner.opam $(LIBDIR)/opam + $(INSTALL) -m 644 pkg/META $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) + $(INSTALL) -m 644 cmdliner.opam $(LIBDIR)/opam install-byte: create-libdir - $(INSTALL) $(BASE).cma $(LIBDIR) + $(INSTALL) -m 644 $(BASE).cma $(LIBDIR) install-native: create-libdir - $(INSTALL) $(BASE).cmxa $(BASE)$(EXT_LIB) $(wildcard $(B)/cmdliner*.cmx) \ + $(INSTALL) -m 644 $(BASE).cmxa $(BASE)$(EXT_LIB) $(wildcard $(B)/cmdliner*.cmx) \ $(LIBDIR) install-native-dynlink: create-libdir - $(INSTALL) $(BASE).cmxs $(LIBDIR) + $(INSTALL) -m 644 $(BASE).cmxs $(LIBDIR) .PHONY: all install install-doc clean build-byte build-native \ build-native-dynlink create-libdir install-common install-byte \ -- cgit v1.2.3 From eeffc613138c28c8b596109fb2f70dfef4801d84 Mon Sep 17 00:00:00 2001 From: Hendrik Tews Date: Tue, 23 Jul 2019 09:38:37 +0200 Subject: install without adding execute permissions Gbp-Pq: Name install-x.patch --- Makefile | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Makefile b/Makefile index 1d2ffd4..e116b6f 100644 --- a/Makefile +++ b/Makefile @@ -41,7 +41,7 @@ install: $(INSTALL-TARGETS) install-doc: $(INSTALL) -d $(DOCDIR) - $(INSTALL) CHANGES.md LICENSE.md README.md $(DOCDIR) + $(INSTALL) -m 644 CHANGES.md LICENSE.md README.md $(DOCDIR) clean: ocaml build.ml clean @@ -59,18 +59,18 @@ create-libdir: $(INSTALL) -d $(LIBDIR) install-common: create-libdir - $(INSTALL) pkg/META $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) - $(INSTALL) cmdliner.opam $(LIBDIR)/opam + $(INSTALL) -m 644 pkg/META $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) + $(INSTALL) -m 644 cmdliner.opam $(LIBDIR)/opam install-byte: create-libdir - $(INSTALL) $(BASE).cma $(LIBDIR) + $(INSTALL) -m 644 $(BASE).cma $(LIBDIR) install-native: create-libdir - $(INSTALL) $(BASE).cmxa $(BASE)$(EXT_LIB) $(wildcard $(B)/cmdliner*.cmx) \ + $(INSTALL) -m 644 $(BASE).cmxa $(BASE)$(EXT_LIB) $(wildcard $(B)/cmdliner*.cmx) \ $(LIBDIR) install-native-dynlink: create-libdir - $(INSTALL) $(BASE).cmxs $(LIBDIR) + $(INSTALL) -m 644 $(BASE).cmxs $(LIBDIR) .PHONY: all install install-doc clean build-byte build-native \ build-native-dynlink create-libdir install-common install-byte \ -- cgit v1.2.3 From 199827d61b23c8c1bc8a6cea8566c66ac7cfc94b Mon Sep 17 00:00:00 2001 From: Julien Puydt Date: Wed, 29 Jun 2022 11:33:06 +0200 Subject: Import cmdliner_1.1.1-1.debian.tar.xz [dgit import tarball cmdliner 1.1.1-1 cmdliner_1.1.1-1.debian.tar.xz] --- changelog | 88 ++++++++++++++++++++++++++++++++++++++++ control | 40 ++++++++++++++++++ copyright | 23 +++++++++++ examples | 1 + gbp.conf | 2 + libcmdliner-ocaml-dev.docs | 1 + libcmdliner-ocaml-dev.install.in | 1 + libcmdliner-ocaml-dev.ocamldoc | 1 + patches/install-x.patch | 43 ++++++++++++++++++++ patches/series | 1 + rules | 21 ++++++++++ source/format | 1 + watch | 2 + 13 files changed, 225 insertions(+) create mode 100644 changelog create mode 100644 control create mode 100644 copyright create mode 100644 examples create mode 100644 gbp.conf create mode 100644 libcmdliner-ocaml-dev.docs create mode 100644 libcmdliner-ocaml-dev.install.in create mode 100644 libcmdliner-ocaml-dev.ocamldoc create mode 100644 patches/install-x.patch create mode 100644 patches/series create mode 100755 rules create mode 100644 source/format create mode 100644 watch diff --git a/changelog b/changelog new file mode 100644 index 0000000..3401734 --- /dev/null +++ b/changelog @@ -0,0 +1,88 @@ +cmdliner (1.1.1-1) unstable; urgency=medium + + * Team upload. + * New upstream release. + * Refresh patch. + + -- Julien Puydt Wed, 29 Jun 2022 11:33:06 +0200 + +cmdliner (1.0.4-2) unstable; urgency=medium + + * debian/rules: + - do not export BUILD_PATH_PREFIX_MAP + - include ocamlvars.mk + * Build-depend on debhelper-compat + * Bump Standards-Version to 4.5.0 + * Add Rules-Requires-Root: no + + -- Stéphane Glondu Tue, 28 Jan 2020 08:47:44 +0100 + +cmdliner (1.0.4-1) unstable; urgency=medium + + * New upstream release + * Bump Standards-Version to 4.4.0 + * Bump debhelper compat level to 12 + * Uploaders: remove Hendrik and add myself + + -- Stéphane Glondu Tue, 23 Jul 2019 15:30:31 +0200 + +cmdliner (1.0.2-1) unstable; urgency=medium + + [ Hendrik Tews ] + * New upstream version 1.0.2 + * compat level 10, standards version 4.0.0 + * add build dependency libresult-ocaml-dev + * update VCS fields + * add myself to uploaders + * updated copyright + * update rules: remove most of the overrides, build sequential because + ocamlbuild would otherwise fail + * remove .doc-base file: there is no documentation any more + * fix .docs file + * add patch install-x for removing x-permission in make install + * add README.Debian to point to the online documentation + * generate documentation with dh_ocamldoc, the command line switches in + libcmdliner-ocaml-dev.ocamldoc have been copied from a run of ``topkg doc'' + * remove README.Debian again + + [ Mehdi Dogguy ] + * Update Vcs-* fields to target Salsa + + -- Mehdi Dogguy Fri, 11 May 2018 15:30:44 +0200 + +cmdliner (0.9.8-2) unstable; urgency=medium + + * Team upload + * Add ocamlbuild to Build-Depends + + -- Stéphane Glondu Sat, 15 Jul 2017 16:06:19 +0200 + +cmdliner (0.9.8-1) unstable; urgency=medium + + * New upstream release + + -- Mehdi Dogguy Mon, 18 Jan 2016 00:35:03 +0100 + +cmdliner (0.9.7-1) unstable; urgency=medium + + * Team upload + * New upstream release + * Update debian/watch + * Update Vcs-* + * Bump Standards-Version to 3.9.6 + + -- Stéphane Glondu Tue, 07 Jul 2015 11:22:00 +0200 + +cmdliner (0.9.4-1) unstable; urgency=medium + + * New upstream release. + * Use a new build system in order to avoid unnecessary new build + dependencies. + + -- Mehdi Dogguy Thu, 27 Mar 2014 21:50:58 +0100 + +cmdliner (0.9.3-1) unstable; urgency=low + + * Initial upload (Closes: #641986) + + -- Mehdi Dogguy Sun, 06 Jan 2013 10:50:00 +0200 diff --git a/control b/control new file mode 100644 index 0000000..957cc38 --- /dev/null +++ b/control @@ -0,0 +1,40 @@ +Source: cmdliner +Section: ocaml +Priority: optional +Maintainer: Debian OCaml Maintainers +Uploaders: + Mehdi Dogguy , + Stéphane Glondu +Build-Depends: + debhelper-compat (= 12), + ocaml-nox, + ocaml-findlib, + ocamlbuild, + libresult-ocaml-dev, + dh-ocaml +Standards-Version: 4.5.0 +Rules-Requires-Root: no +Homepage: http://erratique.ch/software/cmdliner +Vcs-Git: https://salsa.debian.org/ocaml-team/cmdliner.git +Vcs-Browser: https://salsa.debian.org/ocaml-team/cmdliner + +Package: libcmdliner-ocaml-dev +Architecture: any +Depends: + ${ocaml:Depends}, + ${shlibs:Depends}, + ${misc:Depends} +Suggests: + ocaml-findlib +Provides: + ${ocaml:Provides} +Description: declarative definition of command line interfaces + 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 syntax errors, help messages and + UNIX man page generation. It supports programs with single or + multiple commands (like darcs or git) and respects most of the POSIX + and GNU conventions. + . + This package contains the development modules you need to use Cmdliner + in your programs. diff --git a/copyright b/copyright new file mode 100644 index 0000000..11d1db1 --- /dev/null +++ b/copyright @@ -0,0 +1,23 @@ +Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Source: http://erratique.ch/logiciel/cmdliner + +Files: * +Copyright: (c) 2011 Daniel C. Bünzli +License: ISC + 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. + +Files: debian/* +Copyright: © 2013 Mehdi Dogguy +License: GPL-2 + The Debian packaging is licensed under the GPL, see + `/usr/share/common-licenses/GPL-2'. diff --git a/examples b/examples new file mode 100644 index 0000000..ab1cfb4 --- /dev/null +++ b/examples @@ -0,0 +1 @@ +test/* diff --git a/gbp.conf b/gbp.conf new file mode 100644 index 0000000..cec628c --- /dev/null +++ b/gbp.conf @@ -0,0 +1,2 @@ +[DEFAULT] +pristine-tar = True diff --git a/libcmdliner-ocaml-dev.docs b/libcmdliner-ocaml-dev.docs new file mode 100644 index 0000000..b43bf86 --- /dev/null +++ b/libcmdliner-ocaml-dev.docs @@ -0,0 +1 @@ +README.md diff --git a/libcmdliner-ocaml-dev.install.in b/libcmdliner-ocaml-dev.install.in new file mode 100644 index 0000000..73752c9 --- /dev/null +++ b/libcmdliner-ocaml-dev.install.in @@ -0,0 +1 @@ +usr diff --git a/libcmdliner-ocaml-dev.ocamldoc b/libcmdliner-ocaml-dev.ocamldoc new file mode 100644 index 0000000..cdd34fb --- /dev/null +++ b/libcmdliner-ocaml-dev.ocamldoc @@ -0,0 +1 @@ +-colorize-code -charset utf-8 -package bytes -package result diff --git a/patches/install-x.patch b/patches/install-x.patch new file mode 100644 index 0000000..cb1cb63 --- /dev/null +++ b/patches/install-x.patch @@ -0,0 +1,43 @@ +From: Hendrik Tews +Date: Tue, 23 Jul 2019 09:38:37 +0200 +Subject: install without adding execute permissions + +--- + Makefile | 12 ++++++------ + 1 file changed, 6 insertions(+), 6 deletions(-) + +--- cmdliner.orig/Makefile ++++ cmdliner/Makefile +@@ -41,7 +41,7 @@ + + install-doc: + $(INSTALL) -d $(DOCDIR)/odoc-pages +- $(INSTALL) CHANGES.md LICENSE.md README.md $(DOCDIR) ++ $(INSTALL) -m 644 CHANGES.md LICENSE.md README.md $(DOCDIR) + $(INSTALL) doc/index.mld doc/cli.mld doc/examples.mld doc/tutorial.mld \ + doc/tool_man.mld $(DOCDIR)/odoc-pages + +@@ -61,18 +61,18 @@ + $(INSTALL) -d $(LIBDIR) + + install-common: create-libdir +- $(INSTALL) pkg/META $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) +- $(INSTALL) cmdliner.opam $(LIBDIR)/opam ++ $(INSTALL) -m 644 pkg/META $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) ++ $(INSTALL) -m 644 cmdliner.opam $(LIBDIR)/opam + + install-byte: create-libdir +- $(INSTALL) $(BASE).cma $(LIBDIR) ++ $(INSTALL) -m 644 $(BASE).cma $(LIBDIR) + + install-native: create-libdir +- $(INSTALL) $(BASE).cmxa $(BASE)$(EXT_LIB) $(wildcard $(B)/cmdliner*.cmx) \ ++ $(INSTALL) -m 644 $(BASE).cmxa $(BASE)$(EXT_LIB) $(wildcard $(B)/cmdliner*.cmx) \ + $(LIBDIR) + + install-native-dynlink: create-libdir +- $(INSTALL) $(BASE).cmxs $(LIBDIR) ++ $(INSTALL) -m 644 $(BASE).cmxs $(LIBDIR) + + .PHONY: all install install-doc clean build-byte build-native \ + build-native-dynlink create-libdir install-common install-byte \ diff --git a/patches/series b/patches/series new file mode 100644 index 0000000..c476b32 --- /dev/null +++ b/patches/series @@ -0,0 +1 @@ +install-x.patch diff --git a/rules b/rules new file mode 100755 index 0000000..5ceef0e --- /dev/null +++ b/rules @@ -0,0 +1,21 @@ +#!/usr/bin/make -f +# -*- makefile -*- + +DESTDIR=$(CURDIR)/debian/tmp + +include /usr/share/ocaml/ocamlvars.mk + +%: + dh $@ --with ocaml --no-parallel + +.PHONY: override_dh_auto_install +override_dh_auto_install: + make DESTDIR=$(DESTDIR) install + +.PHONY: override_dh_install +override_dh_install: + dh_install --exclude=opam + +.PHONY: override_dh_missing +override_dh_missing: + dh_missing --fail-missing diff --git a/source/format b/source/format new file mode 100644 index 0000000..163aaf8 --- /dev/null +++ b/source/format @@ -0,0 +1 @@ +3.0 (quilt) diff --git a/watch b/watch new file mode 100644 index 0000000..0519bd7 --- /dev/null +++ b/watch @@ -0,0 +1,2 @@ +version=3 +https://erratique.ch/software/cmdliner/releases/ .*cmdliner-(.+)\.tbz -- cgit v1.2.3 From e429e131f50d2a1c26d16672c281a60ea21c709a Mon Sep 17 00:00:00 2001 From: Julien Puydt Date: Wed, 29 Jun 2022 11:33:06 +0200 Subject: Import cmdliner_1.1.1.orig.tar.bz2 [dgit import orig cmdliner_1.1.1.orig.tar.bz2] --- B0.ml | 65 +++ BRZO | 1 + CHANGES.md | 406 ++++++++++++++ LICENSE.md | 13 + Makefile | 79 +++ README.md | 49 ++ _tags | 4 + build.ml | 155 ++++++ cmdliner.opam | 32 ++ doc/cli.mld | 121 ++++ doc/examples.mld | 443 +++++++++++++++ doc/index.mld | 34 ++ doc/tool_man.mld | 70 +++ doc/tutorial.mld | 203 +++++++ dune-project | 2 + pkg/META | 7 + pkg/pkg.ml | 40 ++ src/cmdliner.ml | 33 ++ src/cmdliner.mli | 1176 +++++++++++++++++++++++++++++++++++++++ src/cmdliner.mllib | 12 + src/cmdliner_arg.ml | 377 +++++++++++++ src/cmdliner_arg.mli | 115 ++++ src/cmdliner_base.ml | 357 ++++++++++++ src/cmdliner_base.mli | 76 +++ src/cmdliner_cline.ml | 219 ++++++++ src/cmdliner_cline.mli | 36 ++ src/cmdliner_cmd.ml | 46 ++ src/cmdliner_cmd.mli | 40 ++ src/cmdliner_docgen.ml | 407 ++++++++++++++ src/cmdliner_docgen.mli | 27 + src/cmdliner_eval.ml | 292 ++++++++++ src/cmdliner_eval.mli | 60 ++ src/cmdliner_exit.ml | 21 + src/cmdliner_exit.mli | 21 + src/cmdliner_info.ml | 241 ++++++++ src/cmdliner_info.mli | 155 ++++++ src/cmdliner_manpage.ml | 513 +++++++++++++++++ src/cmdliner_manpage.mli | 100 ++++ src/cmdliner_msg.ml | 122 ++++ src/cmdliner_msg.mli | 56 ++ src/cmdliner_term.ml | 98 ++++ src/cmdliner_term.mli | 51 ++ src/cmdliner_term_deprecated.ml | 93 ++++ src/cmdliner_trie.ml | 96 ++++ src/cmdliner_trie.mli | 34 ++ src/dune | 4 + test/chorus.ml | 35 ++ test/cp_ex.ml | 53 ++ test/darcs_ex.ml | 148 +++++ test/dune | 13 + test/revolt.ml | 9 + test/rm_ex.ml | 60 ++ test/tail_ex.ml | 85 +++ test/test_dupe_stdopts.ml | 40 ++ test/test_man.ml | 101 ++++ test/test_man_utf8.ml | 9 + test/test_nest.ml | 62 +++ test/test_opt_req.ml | 15 + test/test_pos.ml | 13 + test/test_pos_all.ml | 11 + test/test_pos_left.ml | 11 + test/test_pos_req.ml | 15 + test/test_pos_rev.ml | 14 + test/test_term_dups.ml | 19 + test/test_with_used_args.ml | 18 + 65 files changed, 7333 insertions(+) create mode 100644 B0.ml create mode 100644 BRZO create mode 100644 CHANGES.md create mode 100644 LICENSE.md create mode 100644 Makefile create mode 100644 README.md create mode 100644 _tags create mode 100755 build.ml create mode 100644 cmdliner.opam create mode 100644 doc/cli.mld create mode 100644 doc/examples.mld create mode 100644 doc/index.mld create mode 100644 doc/tool_man.mld create mode 100644 doc/tutorial.mld create mode 100644 dune-project create mode 100644 pkg/META create mode 100755 pkg/pkg.ml create mode 100644 src/cmdliner.ml create mode 100644 src/cmdliner.mli create mode 100644 src/cmdliner.mllib create mode 100644 src/cmdliner_arg.ml create mode 100644 src/cmdliner_arg.mli create mode 100644 src/cmdliner_base.ml create mode 100644 src/cmdliner_base.mli create mode 100644 src/cmdliner_cline.ml create mode 100644 src/cmdliner_cline.mli create mode 100644 src/cmdliner_cmd.ml create mode 100644 src/cmdliner_cmd.mli create mode 100644 src/cmdliner_docgen.ml create mode 100644 src/cmdliner_docgen.mli create mode 100644 src/cmdliner_eval.ml create mode 100644 src/cmdliner_eval.mli create mode 100644 src/cmdliner_exit.ml create mode 100644 src/cmdliner_exit.mli create mode 100644 src/cmdliner_info.ml create mode 100644 src/cmdliner_info.mli create mode 100644 src/cmdliner_manpage.ml create mode 100644 src/cmdliner_manpage.mli create mode 100644 src/cmdliner_msg.ml create mode 100644 src/cmdliner_msg.mli create mode 100644 src/cmdliner_term.ml create mode 100644 src/cmdliner_term.mli create mode 100644 src/cmdliner_term_deprecated.ml create mode 100644 src/cmdliner_trie.ml create mode 100644 src/cmdliner_trie.mli create mode 100644 src/dune create mode 100644 test/chorus.ml create mode 100644 test/cp_ex.ml create mode 100644 test/darcs_ex.ml create mode 100644 test/dune create mode 100644 test/revolt.ml create mode 100644 test/rm_ex.ml create mode 100644 test/tail_ex.ml create mode 100644 test/test_dupe_stdopts.ml create mode 100644 test/test_man.ml create mode 100644 test/test_man_utf8.ml create mode 100644 test/test_nest.ml create mode 100644 test/test_opt_req.ml create mode 100644 test/test_pos.ml create mode 100644 test/test_pos_all.ml create mode 100644 test/test_pos_left.ml create mode 100644 test/test_pos_req.ml create mode 100644 test/test_pos_rev.ml create mode 100644 test/test_term_dups.ml create mode 100644 test/test_with_used_args.ml diff --git a/B0.ml b/B0.ml new file mode 100644 index 0000000..7a65936 --- /dev/null +++ b/B0.ml @@ -0,0 +1,65 @@ +open B0_kit.V000 +open B00_std + +(* OCaml library names *) + +let cmdliner = B0_ocaml.libname "cmdliner" + +(* Units *) + +let cmdliner_lib = + let srcs = Fpath.[`Dir (v "src")] in + B0_ocaml.lib cmdliner ~doc:"The cmdliner library" ~srcs ~requires:[] + +(* Tests *) + +let test ?doc t = + let srcs = [`File (Fpath.v (Fmt.str "test/%s.ml" t))] in + let requires = [cmdliner] in + let meta = B0_meta.(empty |> tag test) in + B0_ocaml.exe t ?doc ~srcs ~requires ~meta + +let chorus = test "chorus" +let cp_ex = test "cp_ex" +let darcs_ex = test "darcs_ex" +let revolt = test "revolt" +let rm_ex = test "rm_ex" +let tail_ex = test "tail_ex" +let tail_ex = test "test_nest" +let test_dupe_stdopts = test "test_dupe_stdopts" +let test_man = test "test_man" +let test_man_utf8 = test "test_man_utf8" +let test_opt_req = test "test_opt_req" +let test_pos = test "test_pos" +let test_pos_all = test "test_pos_all" +let test_pos_left = test "test_pos_left" +let test_pos_req = test "test_pos_req" +let test_pos_rev = test "test_pos_rev" +let test_term_dups = test "test_term_dups" +let test_with_used_args = test "test_with_used_args" + +(* Packs *) + +let default = + let meta = + let open B0_meta in + empty + |> add authors ["The cmdliner programmers"] + |> add maintainers ["Daniel Bünzli "] + |> add homepage "https://erratique.ch/software/cmdliner" + |> add online_doc "https://erratique.ch/software/cmdliner/doc" + |> add issues "https://github.com/dbuenzli/cmdliner/issues" + |> add repo "git+https://erratique.ch/repos/cmdliner.git" + |> add licenses ["ISC"] + |> add description_tags ["cli"; "system"; "declarative"; "org:erratique"] + |> tag B0_opam.tag + |> add B0_opam.Meta.depends + [ "ocaml", {|>= "4.08.0"|}; ] + |> add B0_opam.Meta.build + {|[[ make "all" "PREFIX=%{prefix}%" ]]|} + |> add B0_opam.Meta.install + {|[[make "install" "LIBDIR=%{_:lib}%" "DOCDIR=%{_:doc}%"] + [make "install-doc" "LIBDIR=%{_:lib}%" "DOCDIR=%{_:doc}%"]]|} + in + B0_pack.v "default" ~doc:"cmdliner package" ~meta ~locked:true @@ + B0_unit.list () diff --git a/BRZO b/BRZO new file mode 100644 index 0000000..b1e48ff --- /dev/null +++ b/BRZO @@ -0,0 +1 @@ +(srcs-x build.ml test pkg) \ No newline at end of file diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 0000000..496860f --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,406 @@ +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 sub command support to allow +arbitrarily nested sub commands 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 sub commands + 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 explicitely 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 sub commands as positional arguments you will effectively break the +command line compatibility of your tool since options can no longer be +specified before the sub commands, 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 overriden 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 misterious 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 sub command 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` aswell. 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. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..c4cd256 --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..aa0a104 --- /dev/null +++ b/Makefile @@ -0,0 +1,79 @@ +# 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 +LIBDIR=$(DESTDIR)$(PREFIX)/lib/ocaml/cmdliner +DOCDIR=$(DESTDIR)$(PREFIX)/share/doc/cmdliner +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)/cmdliner + +ifeq ($(NATIVE),true) + BUILD-TARGETS=build-byte build-native + INSTALL-TARGETS=install-common install-byte install-native + ifeq ($(NATDYNLINK),true) + BUILD-TARGETS += build-native-dynlink + INSTALL-TARGETS += install-native-dynlink + endif +else + BUILD-TARGETS=build-byte + INSTALL-TARGETS=install-common install-byte +endif + +all: $(BUILD-TARGETS) + +install: $(INSTALL-TARGETS) + +install-doc: + $(INSTALL) -d $(DOCDIR)/odoc-pages + $(INSTALL) CHANGES.md LICENSE.md README.md $(DOCDIR) + $(INSTALL) doc/index.mld doc/cli.mld doc/examples.mld doc/tutorial.mld \ + doc/tool_man.mld $(DOCDIR)/odoc-pages + +clean: + ocaml build.ml clean + +build-byte: + ocaml build.ml cma + +build-native: + ocaml build.ml cmxa + +build-native-dynlink: + ocaml build.ml cmxs + +create-libdir: + $(INSTALL) -d $(LIBDIR) + +install-common: create-libdir + $(INSTALL) pkg/META $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) + $(INSTALL) cmdliner.opam $(LIBDIR)/opam + +install-byte: create-libdir + $(INSTALL) $(BASE).cma $(LIBDIR) + +install-native: create-libdir + $(INSTALL) $(BASE).cmxa $(BASE)$(EXT_LIB) $(wildcard $(B)/cmdliner*.cmx) \ + $(LIBDIR) + +install-native-dynlink: create-libdir + $(INSTALL) $(BASE).cmxs $(LIBDIR) + +.PHONY: all install install-doc clean build-byte build-native \ + build-native-dynlink create-libdir install-common install-byte \ + install-native install-dynlink diff --git a/README.md b/README.md new file mode 100644 index 0000000..5a348eb --- /dev/null +++ b/README.md @@ -0,0 +1,49 @@ +Cmdliner — Declarative definition of command line interfaces for OCaml +------------------------------------------------------------------------------- +v1.1.1 + +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 syntax errors, help messages and UNIX man +page generation. It supports programs with single or multiple commands +and respects most of the [POSIX][1] and [GNU][2] conventions. + +Cmdliner has no dependencies and is distributed under the ISC license. + +[1]: http://pubs.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap12.html +[2]: http://www.gnu.org/software/libc/manual/html_node/Argument-Syntax.html + +Home page: http://erratique.ch/software/cmdliner + +## 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 and API reference is automatically generated by from +the source interfaces. It can be consulted [online][doc] or via +`odig doc cmdliner`. + +[doc]: http://erratique.ch/software/cmdliner/doc/Cmdliner + + +## Sample programs + +If you installed Cmdliner with `opam` sample programs are located in +the directory `opam config var cmdliner:doc`. These programs define +the command line of some classic programs. + +In the distribution sample programs are located in the `test` +directory of the distribution. They can be built and run with: + + topkg build --tests true && topkg test diff --git a/_tags b/_tags new file mode 100644 index 0000000..691ae72 --- /dev/null +++ b/_tags @@ -0,0 +1,4 @@ +true : bin_annot, safe_string +<_b0> : -traverse + : include + : include \ No newline at end of file diff --git a/build.ml b/build.ml new file mode 100755 index 0000000..e0d9a3c --- /dev/null +++ b/build.ml @@ -0,0 +1,155 @@ +#!/usr/bin/env ocaml + +(* Usage: ocaml build.ml [cma|cmxa|cmxs|clean] *) + +let root_dir = Sys.getcwd () +let build_dir = "_build" +let src_dir = "src" + +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 mkdir dir = + try match Sys.file_exists dir with + | true -> () + | false -> run_cmd ["mkdir"; dir] + with + | Sys_error e -> err "%s: %s" dir e + +let rmdir dir = + try match Sys.file_exists dir with + | false -> () + | true -> + let rm f = 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 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 build_dir + +let in_build_dir f = + 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 +| _ :: [ "cma" ] -> in_build_dir build_cma +| _ :: [ "cmxa" ] -> in_build_dir build_cmxa +| _ :: [ "cmxs" ] -> in_build_dir 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 () diff --git a/cmdliner.opam b/cmdliner.opam new file mode 100644 index 0000000..7c2dd08 --- /dev/null +++ b/cmdliner.opam @@ -0,0 +1,32 @@ +version: "1.1.1" +opam-version: "2.0" +name: "cmdliner" +synopsis: """Declarative definition of command line interfaces for OCaml""" +maintainer: ["Daniel Bünzli "] +authors: ["The cmdliner programmers"] +homepage: "https://erratique.ch/software/cmdliner" +doc: "https://erratique.ch/software/cmdliner/doc" +dev-repo: "git+https://erratique.ch/repos/cmdliner.git" +bug-reports: "https://github.com/dbuenzli/cmdliner/issues" +license: ["ISC"] +tags: ["cli" "system" "declarative" "org:erratique"] +depends: ["ocaml" {>= "4.08.0"}] +build: [[ make "all" "PREFIX=%{prefix}%" ]] +install: [[make "install" "LIBDIR=%{_:lib}%" "DOCDIR=%{_:doc}%"] + [make "install-doc" "LIBDIR=%{_:lib}%" "DOCDIR=%{_:doc}%"]] +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 syntax errors, help messages and UNIX man +page generation. It supports programs with single or multiple commands +and respects most of the [POSIX][1] and [GNU][2] conventions. + +Cmdliner has no dependencies and is distributed under the ISC license. + +[1]: http://pubs.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap12.html +[2]: http://www.gnu.org/software/libc/manual/html_node/Argument-Syntax.html + +Home page: http://erratique.ch/software/cmdliner""" diff --git a/doc/cli.mld b/doc/cli.mld new file mode 100644 index 0000000..3579933 --- /dev/null +++ b/doc/cli.mld @@ -0,0 +1,121 @@ +{0:cmdline Command line interface} + +For tools evaluating a command without sub commands the most general +form of invocation is: + +{[ +tool [OPTION]… [ARG]… +]} + +The tool automatically reponds to the [--help] option by printing 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 sub commands have this form of invocation + +{[ +tool [COMMAND]… [OPTION]… [ARG]… +]} + +Commands automatically respond to the [--help] option by printing +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 sub command stops. Command names may be specified by +a prefixe as long as they are not ambiguous. + +{1: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. Long names can be specified by any non ambiguous prefix. + +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].}} + +{1: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: + +{[ +tool --option -- we -are --all positional --argu=ments +]} + +{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 that +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:reserved Reserved option names} + +Using the cmdliner library puts the following constraints o + +{ul +{- The option name [--cmdliner] is 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].}} diff --git a/doc/examples.mld b/doc/examples.mld new file mode 100644 index 0000000..e8543ca --- /dev/null +++ b/doc/examples.mld @@ -0,0 +1,443 @@ +{0 Examples} + +The examples are self-contained, cut and paste them in a file to play +with them. + +{1:exrm 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]. + +{[ +(* 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 + +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 cmd = + let doc = "Remove files or directories" in + let man = [ + `S Manpage.s_description; + `P "$(tname) 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 "$(mname) $(b,-- -foo)"; `Noblank; + `Pre "$(mname) $(b,./-foo)"; + `P "$(tname) removes symbolic links, not the files referenced by the + links."; + `S Manpage.s_bugs; `P "Report bugs to ."; + `S Manpage.s_see_also; `P "$(b,rmdir)(1), $(b,unlink)(2)" ] + in + let info = Cmd.info "rm" ~version:"v1.1.1" ~doc ~man in + Cmd.v info Term.(const rm $ prompt $ recursive $ files) + +let main () = exit (Cmd.eval cmd) +let () = main () +]} + +{1:excp 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 lifted result [cp_t] of [cp], +[Cmdliner] handles the error reporting. + +{[ +(* 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 + +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 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 ."; ] + in + let info = Cmd.info "cp" ~version:"v1.1.1" ~doc ~man ~man_xrefs in + Cmd.v info Term.(ret (const cp $ verbose $ recurse $ force $ srcs $ dest)) + + +let main () = exit (Cmd.eval cmd) +let () = main () +]} + +{1:extail 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. + +{[ +(* 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 + +let loc_arg = + let parse 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 (`Msg "unable to parse integer") + in + let print ppf p = Format.fprintf ppf "%s" (loc_str p) in + Arg.conv ~docv:"N" (parse, print) + +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 cmd = + let doc = "Display the last part of a file" in + let man = [ + `S Manpage.s_description; + `P "$(tname) 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 ."; + `S Manpage.s_see_also; + `P "$(b,cat)(1), $(b,head)(1)" ] + in + let info = Cmd.info "tail" ~version:"v1.1.1" ~doc ~man in + Cmd.v info Term.(const tail $ lines $ follow $ verb $ pid $ files) + + +let main () = exit (Cmd.eval cmd) +let () = main () +]} + +{1:exdarcs 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 a section called [COMMON +OPTIONS], since we also want to put [--help] and [--version] in this +section, the term information of commands makes a judicious use of the +[sdocs] parameter of {!Cmdliner.Term.val-info}. + +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_cmd] term. + +{[ +(* 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 + match conv 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 + +(* 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 $(mname) $(i,COMMAND) --help for help on a single command.";`Noblank; + `P "Use $(mname) $(b,help patterns) for help on patch matching."; `Noblank; + `P "Use $(mname) $(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 $(mname) 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 + let info = Cmd.info "initialize" ~doc ~sdocs ~man in + Cmd.v info Term.(const 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 + let info = Cmd.info "record" ~doc ~sdocs ~man in + Cmd.v info + Term.(const 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 + let info = Cmd.info "help" ~doc ~man in + Cmd.v info + Term.(ret (const help $ copts_t $ Arg.man_format $ Term.choice_names $ + topic)) + +let main_cmd = + let doc = "a revision control system" in + let man = help_secs in + let info = Cmd.info "darcs" ~version:"v1.1.1" ~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 () = exit (Cmd.eval main_cmd) +]} diff --git a/doc/index.mld b/doc/index.mld new file mode 100644 index 0000000..b543c04 --- /dev/null +++ b/doc/index.mld @@ -0,0 +1,34 @@ +{0 Cmdliner {%html: v1.1.1%}} + +[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 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} gets you through the steps to write + your first command line interface with Cmdliner.} +{- The {{!page-cli}Command line interface manual} describes how command + lines and environment variables are parsed by Cmdliner.} +{- {{!page-tool_man}Tool man pages} describes how Cmdliner generates + man pages for your tools and how you can format them.} +{- The {{!page-examples}examples page} has a few annoted examples that + show to express the command line interface of a few classic tools with + Cmdliner}} + +{1:api API} + +{!modules: +Cmdliner +} diff --git a/doc/tool_man.mld b/doc/tool_man.mld new file mode 100644 index 0000000..0abf475 --- /dev/null +++ b/doc/tool_man.mld @@ -0,0 +1,70 @@ +{0:tool_man Tool man pages} + +{1:manual Manual} + +Man page sections for a command are printed in the order specified by +manual as given to {!Cmdliner.Cmd.val-info}. Unless specified +explicitely in the command's manual the following sections are +automaticaly 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.Arg.val-env_var} and {!Cmdliner.Cmd.Env.val-info}.}} + +If a [docs] section name is mentioned and does not exist in the command's +manual, 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 explicitely specified by the command's manual 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 doc strings 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 term's + man page [$(tname)] is substituted by the term name 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.} +{- Refering to unknown markup directives or variables will generate + errors on standard error during documentation generation.}} diff --git a/doc/tutorial.mld b/doc/tutorial.mld new file mode 100644 index 0000000..528f9c4 --- /dev/null +++ b/doc/tutorial.mld @@ -0,0 +1,203 @@ +{0:tutorial Tutorial} + +{1:started Getting started} + +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 with a term of type {!Cmdliner.Term.t}. 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.($)}. + +For example, in a [revolt.ml] file, for the function: + +{[ +let revolt () = print_endline "Revolt!" +]} + +the term : + +{[ +open Cmdliner + +let revolt_t = Term.(const revolt $ const ()) +]} + +is a term that evaluates to the result (and effect) of the [revolt] +function. This term can be attached to a command: + +{[ +let cmd = Cmd.v (Cmd.info "revolt") revolt_t +]} + +and evaluated with {!Cmdliner.Cmd.val-eval}: +{[ +let () = exit (Cmd.eval cmd) +]} + +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]. + +{[ +> ocamlfind ocamlopt -linkpkg -package cmdliner -o revolt revolt.ml +> ./revolt +Revolt! +]} + +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. + +Terms corresponding to command line argument data that are part of a +term evaluation implicitly define a command line syntax. We show this +on an concrete example. + +In a [chorus.ml] file, consider the [chorus] function that prints +repeatedly a given message : + +{[ +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: + +{[ +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: + +{[ +let count = + let doc = "Repeat the message $(docv) times." in + Arg.(value & opt int 10 & info ["c"; "count"] ~docv:"COUNT" ~doc) +]} + +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: + +{[ +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 ~docv:"MSG" ~doc) +]} + +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. + +The term for executing [chorus] with these command line arguments is : + +{[ +let chorus_t = Term.(const chorus $ count $ msg) +]} + +We are now ready to define the [main] function of our tool: + +{[ +let cmd = + let doc = "print a customizable message repeatedly" in + let man = [ + `S Manpage.s_bugs; + `P "Email bug reports to ." ] + in + let info = Cmd.info "chorus" ~version:"%‌%VERSION%%" ~doc ~man in + Cmd.v info chorus_t + +let main () = exit (Cmd.eval cmd) +let () = main () +]} + +The [info] value created with {!Cmdliner.Cmd.val-info} gives more +information about the term we execute and is used to generate the +tool's man page. Since we provided a [~version] string, the tool +will automatically respond to the [--version] option by printing this +string. + +A tool using {!Cmdliner.Cmd.val-eval} always responds to the [--help] +option by showing the tool's man page generated using the information +you provided with {!Cmdliner.Cmd.val-info} and +{!Cmdliner.Arg.val-info}. Here is the output 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 . +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]. + +For examples of more complex command line definitions look and run +the {{!page-examples}examples}. + +{1:subcommands Sub commands} + +[Cmdliner] also provides support for programs like [git] that have sub +commands each with their own command line syntax and manual: + +{[tool [COMMAND]… [OPTION]… ARG…]} + +These sub commands are defined by grouping them under a parent command +via the {!Cmdliner.Cmd.group} function. diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..f4beddd --- /dev/null +++ b/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.4) +(name cmdliner) \ No newline at end of file diff --git a/pkg/META b/pkg/META new file mode 100644 index 0000000..0eba8e8 --- /dev/null +++ b/pkg/META @@ -0,0 +1,7 @@ +version = "v1.1.1" +description = "Declarative definition of command line interfaces" +requires = "" +archive(byte) = "cmdliner.cma" +archive(native) = "cmdliner.cmxa" +plugin(byte) = "cmdliner.cma" +plugin(native) = "cmdliner.cmxs" \ No newline at end of file diff --git a/pkg/pkg.ml b/pkg/pkg.ml new file mode 100755 index 0000000..d0cc73a --- /dev/null +++ b/pkg/pkg.ml @@ -0,0 +1,40 @@ +#!/usr/bin/env ocaml +#use "topfind" +#require "topkg" +open Topkg + +let test t = Pkg.flatten [ Pkg.test ~run:false t; Pkg.doc (t ^ ".ml")] + +let distrib = + let exclude_paths () = Ok [".git";".gitignore";".gitattributes";"_build"] in + Pkg.distrib ~exclude_paths () + +let opams = + [Pkg.opam_file "cmdliner.opam"] + +let () = + Pkg.describe ~distrib "cmdliner" ~opams @@ fun c -> + Ok [ Pkg.mllib ~api:["Cmdliner"] "src/cmdliner.mllib"; + Pkg.doc "doc/index.mld" ~dst:"odoc-pages/index.mld"; + Pkg.doc "doc/tutorial.mld" ~dst:"odoc-pages/tutorial.mld"; + Pkg.doc "doc/cli.mld" ~dst:"odoc-pages/cli.mld"; + Pkg.doc "doc/examples.mld" ~dst:"odoc-pages/examples.mld"; + Pkg.doc "doc/tool_man.mld" ~dst:"odoc-pages/tool_man.mld"; + test "test/chorus"; + test "test/cp_ex"; + test "test/darcs_ex"; + test "test/revolt"; + test "test/rm_ex"; + test "test/tail_ex"; + Pkg.test ~run:false "test/test_dupe_stdopts"; + Pkg.test ~run:false "test/test_nest"; + Pkg.test ~run:false "test/test_man"; + Pkg.test ~run:false "test/test_man_utf8"; + Pkg.test ~run:false "test/test_pos"; + Pkg.test ~run:false "test/test_pos_rev"; + Pkg.test ~run:false "test/test_pos_all"; + Pkg.test ~run:false "test/test_pos_left"; + Pkg.test ~run:false "test/test_pos_req"; + Pkg.test ~run:false "test/test_opt_req"; + Pkg.test ~run:false "test/test_term_dups"; + Pkg.test ~run:false "test/test_with_used_args"; ] diff --git a/src/cmdliner.ml b/src/cmdliner.ml new file mode 100644 index 0000000..b5b1f11 --- /dev/null +++ b/src/cmdliner.ml @@ -0,0 +1,33 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +module Manpage = Cmdliner_manpage +module Term = struct + include Cmdliner_term + include Cmdliner_term_deprecated +end +module Cmd = struct + module Exit = Cmdliner_info.Exit + module Env = Cmdliner_info.Env + include Cmdliner_cmd + include Cmdliner_eval +end +module Arg = Cmdliner_arg + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner.mli b/src/cmdliner.mli new file mode 100644 index 0000000..43622e2 --- /dev/null +++ b/src/cmdliner.mli @@ -0,0 +1,1176 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(** Declarative definition of command line interfaces. + + Consult the {{!page-tutorial}tutorial}, details about the supported + {{!page-cli}command line syntax} and {{!page-examples}examples} of + use. + + Open the module to use it, it defines only three modules in your + scope. *) + +(** Man page specification. + + Man page generation is automatically handled by [Cmdliner], + consult the {{!page-tool_man.manual}details}. + + The {!Manpage.block} type is used to define a man page's + content. It's a good idea to follow the + {{!Manpage.standard_sections}standard} manual page structure. + + {b References.} + {ul + {- [man-pages(7)], {{:http://man7.org/linux/man-pages/man7/man-pages.7.html} + {e Conventions for writing Linux man pages}}.}} *) +module Manpage : sig + + (** {1:man Man pages} *) + + type block = + [ `S of string | `P of string | `Pre of string | `I of string * string + | `Noblank | `Blocks of block list ] + (** The type for a block of man page text. + + {ul + {- [`S s] introduces a new section [s], see the + {{!standard_sections}standard section names}.} + {- [`P t] is a new paragraph with text [t].} + {- [`Pre t] is a new preformatted paragraph with text [t].} + {- [`I (l,t)] is an indented paragraph with label + [l] and text [t].} + {- [`Noblank] suppresses the blank line introduced between two blocks.} + {- [`Blocks bs] splices the blocks [bs].}} + + Except in [`Pre], whitespace and newlines are not significant + and are all collapsed to a single space. All block strings + support the {{!page-tool_man.doclang}documentation markup language}.*) + + val escape : string -> string + (** [escape s] escapes [s] so that it doesn't get interpreted by the + {{!page-tool_man.doclang}documentation markup language}. *) + + type title = string * int * string * string * string + (** The type for man page titles. Describes the man page + [title], [section], [center_footer], [left_footer], [center_header]. *) + + type t = title * block list + (** The type for a man page. A title and the page text as a list of blocks. *) + + type xref = + [ `Main | `Cmd of string | `Tool of string | `Page of string * int ] + (** The type for man page cross-references. + {ul + {- [`Main] refers to the man page of the program itself.} + {- [`Cmd cmd] refers to the man page of the program's [cmd] + command (which must exist).} + {- [`Tool bin] refers to the command line tool named [bin].} + {- [`Page (name, sec)] refers to the man page [name(sec)].}} *) + + (** {1:standard_sections Standard section names and content} + + The following are standard man page section names, roughly ordered + in the order they conventionally appear. See also + {{:http://man7.org/linux/man-pages/man7/man-pages.7.html}[man man-pages]} + for more elaborations about what sections should contain. *) + + val s_name : string + (** The [NAME] section. This section is automatically created by + [Cmdliner] for your. *) + + val s_synopsis : string + (** The [SYNOPSIS] section. By default this section is automatically + created by [Cmdliner] for you, unless it is the first section of + your term's man page, in which case it will replace it with yours. *) + + val s_description : string + (** The [DESCRIPTION] section. This should be a description of what + the tool does and provide a little bit of usage and + documentation guidance. *) + + val s_commands : string + (** The [COMMANDS] section. By default subcommands get listed here. *) + + val s_arguments : string + (** The [ARGUMENTS] section. By default positional arguments get + listed here. *) + + val s_options : string + (** The [OPTIONS] section. By default optional arguments get + listed here. *) + + val s_common_options : string + (** The [COMMON OPTIONS] section. By default help and version options get + listed here. For programs with multiple commands, optional arguments + common to all commands can be added here. *) + + val s_exit_status : string + (** The [EXIT STATUS] section. By default term status exit codes + get listed here. *) + + val s_environment : string + (** The [ENVIRONMENT] section. By default environment variables get + listed here. *) + + val s_environment_intro : block + (** [s_environment_intro] is the introduction content used by cmdliner + when it creates the {!s_environment} section. *) + + val s_files : string + (** The [FILES] section. *) + + val s_bugs : string + (** The [BUGS] section. *) + + val s_examples : string + (** The [EXAMPLES] section. *) + + val s_authors : string + (** The [AUTHORS] section. *) + + val s_see_also : string + (** The [SEE ALSO] section. *) + + val s_none : string + (** [s_none] is a special section named ["cmdliner-none"] that can be used + whenever you do not want something to be listed. *) + + (** {1:output Output} + + The {!print} function can be useful if the client wants to define + other man pages (e.g. to implement a help command). *) + + type format = [ `Auto | `Pager | `Plain | `Groff ] + (** The type for man page output specification. + {ul + {- [`Auto], formats like [`Pager] or [`Plain] whenever the [TERM] + environment variable is [dumb] or unset.} + {- [`Pager], tries to write to a discovered pager, if that fails + uses the [`Plain] format.} + {- [`Plain], formats to plain text.} + {- [`Groff], formats to groff commands.}} *) + + val print : + ?errs:Format.formatter -> + ?subst:(string -> string option) -> format -> Format.formatter -> t -> unit + (** [print ~errs ~subst fmt ppf page] prints [page] on [ppf] in the + format [fmt]. [subst] can be used to perform variable + substitution,(defaults to the identity). [errs] is used to print + formatting errors, it defaults to {!Format.err_formatter}. *) +end + +(** Terms. + + A term is evaluated by a program to produce a {{!Term.result}result}, + which can be turned into an {{!Term.exits}exit status}. A term made of terms + referring to {{!Arg}command line arguments} implicitly defines a + command line syntax. *) +module Term : sig + + (** {1:terms Terms} *) + + type +'a t + (** The type for terms evaluating to values of type 'a. *) + + val const : 'a -> 'a t + (** [const v] is a term that evaluates to [v]. *) + + val ( $ ) : ('a -> 'b) t -> 'a t -> 'b t + (** [f $ v] is a term that evaluates to the result of applying + the evaluation of [v] to the one of [f]. *) + + val app : ('a -> 'b) t -> 'a t -> 'b t + (** [app] is {!($)}. *) + + (** {1 Interacting with Cmdliner's evaluation} *) + + val term_result : ?usage:bool -> ('a, [`Msg of string]) result t -> 'a t + (** [term_result ~usage t] evaluates to + {ul + {- [`Ok v] if [t] evaluates to [Ok v]} + {- [`Error `Term] with the error message [e] and usage shown according + to [usage] (defaults to [false]), if [t] evaluates to + [Error (`Msg e)].}} + + See also {!term_result'}. *) + + val term_result' : ?usage:bool -> ('a, string) result t -> 'a t + (** [term_result'] is like {!term_result} but with a [string] + error case. *) + + val cli_parse_result : ('a, [`Msg of string]) result t -> 'a t + (** [cli_parse_result t] is a term that evaluates to: + {ul + {- [`Ok v] if [t] evaluates to [Ok v].} + {- [`Error `Parse] with the error message [e] + if [t] evaluates to [Error (`Msg e)].}} + + See also {!cli_parse_result'}. *) + + val cli_parse_result' : ('a, string) result t -> 'a t + (** [cli_parse_result'] is like {!cli_parse_result} but with a [string] + error case. *) + + val main_name : string t + (** [main_name] is a term that evaluates to the main command name; + that is the name of the tool. *) + + val choice_names : string list t + (** [choice_names] is a term that evaluates to the names of the commands + that are children of the main command. *) + + val with_used_args : 'a t -> ('a * string list) t + (** [with_used_args t] is a term that evaluates to [t] tupled + with the arguments from the command line that where used to + evaluate [t]. *) + + type 'a ret = + [ `Help of Manpage.format * string option + | `Error of (bool * string) + | `Ok of 'a ] + (** The type for command return values. See {!val-ret}. *) + + val ret : 'a ret t -> 'a t + (** [ret v] is a term whose evaluation depends on the case + to which [v] evaluates. With : + {ul + {- [`Ok v], it evaluates to [v].} + {- [`Error (usage, e)], the evaluation fails and [Cmdliner] prints + the error [e] and the term's usage if [usage] is [true].} + {- [`Help (format, name)], the evaluation fails and [Cmdliner] prints + a manpage in format [format]. If [name] is [None] this is the + the main command's manpage. If [name] is [Some c] this is + the man page of the sub command [c] of the main command.}} + + {b Note.} While not deprecated you are encouraged not use this API. *) + + (** {1:deprecated Deprecated Term evaluation interface} + + This interface is deprecated in favor of {!Cmdliner.Cmd}. Follow + the compiler deprecation warning hints to transition. *) + + (** {2:tinfo Term information} + + Term information defines the name and man page of a term. + For simple evaluation this is the name of the program and its + man page. For multiple term evaluation, this is + the name of a command and its man page. *) + + [@@@alert "-deprecated"] (* Need to be able to mention them ! *) + + type exit_info + [@@ocaml.deprecated "Use Cmd.Exit.info instead."] + (** The type for exit status information. *) + + val exit_info : ?docs:string -> ?doc:string -> ?max:int -> int -> exit_info + [@@ocaml.deprecated "Use Cmd.Exit.info instead."] + (** [exit_info ~docs ~doc min ~max] describe the range of exit + statuses from [min] to [max] (defaults to [min]). [doc] is the + man page information for the statuses, defaults to ["undocumented"]. + [docs] is the title of the man page section in which the statuses + will be listed, it defaults to {!Manpage.s_exit_status}. + + In [doc] the {{!page-tool_man.doclang}documentation markup language} + can be used with following variables: + {ul + {- [$(status)], the value of [min].} + {- [$(status_max)], the value of [max].} + {- The variables mentioned in {!val-info}}} *) + + val default_exits : exit_info list + [@@ocaml.deprecated + "Use Cmd.Exit.defaults or Cmd.info's defaults ~exits value instead."] + (** [default_exits] is information for exit status {!exit_status_success} + added to {!default_error_exits}. *) + + val default_error_exits : exit_info list + [@@ocaml.deprecated "List.filter the Cmd.Exit.defaults value instead."] + (** [default_error_exits] is information for exit statuses + {!exit_status_cli_error} and {!exit_status_internal_error}. *) + + type env_info + [@@ocaml.deprecated "Use Cmd.Env.info instead."] + (** The type for environment variable information. *) + + val env_info : ?docs:string -> ?doc:string -> string -> env_info + [@@ocaml.deprecated "Use Cmd.Env.info instead."] + (** [env_info ~docs ~doc var] describes an environment variable + [var]. [doc] is the man page information of the environment + variable, defaults to ["undocumented"]. [docs] is the title of + the man page section in which the environment variable will be + listed, it defaults to {!Cmdliner.Manpage.s_environment}. + + In [doc] the {{!page-tool_man.doclang}documentation markup language} + can be used with following variables: + {ul + {- [$(env)], the value of [var].} + {- The variables mentioned in {!val-info}}} *) + + type info + [@@ocaml.deprecated "Use Cmd.info instead."] + (** The type for term information. *) + + val info : + ?man_xrefs:Manpage.xref list -> ?man:Manpage.block list -> + ?envs:env_info list -> ?exits:exit_info list -> ?sdocs:string -> + ?docs:string -> ?doc:string -> ?version:string -> string -> info + [@@ocaml.deprecated "Use Cmd.info instead."] + (** [info sdocs man docs doc version name] is a term information + such that: + {ul + {- [name] is the name of the program or the command.} + {- [version] is the version string of the program, ignored + for commands.} + {- [doc] is a one line description of the program or command used + for the [NAME] section of the term's man page. For commands this + description is also used in the list of commands of the main + term's man page.} + {- [docs], only for commands, the title of the section of the main + term's man page where it should be listed (defaults to + {!Manpage.s_commands}).} + {- [sdocs] defines the title of the section in which the + standard [--help] and [--version] arguments are listed + (defaults to {!Manpage.s_options}).} + {- [exits] is a list of exit statuses that the term evaluation + may produce.} + {- [envs] is a list of environment variables that influence + the term's evaluation.} + {- [man] is the text of the man page for the term.} + {- [man_xrefs] are cross-references to other manual pages. These + are used to generate a {!Manpage.s_see_also} section.}} + [doc], [man], [envs] support the {{!page-tool_man.doclang}documentation + markup language} in which the following variables are recognized: + {ul + {- [$(tname)] the term's name.} + {- [$(mname)] the main term's name.}} *) + + val name : info -> string + [@@ocaml.deprecated "Use Cmd.info_name instead."] + (** [name ti] is the name of the term information. *) + + (** {2:evaluation Evaluation} *) + + type 'a result = + [ `Ok of 'a | `Error of [`Parse | `Term | `Exn ] | `Version | `Help ] + (** The type for evaluation results. + {ul + {- [`Ok v], the term evaluated successfully and [v] is the result.} + {- [`Version], the version string of the main term was printed + on the help formatter.} + {- [`Help], man page about the term was printed on the help formatter.} + {- [`Error `Parse], a command line parse error occurred and was + reported on the error formatter.} + {- [`Error `Term], a term evaluation error occurred and was reported + on the error formatter (see {!Term.val-ret}').} + {- [`Error `Exn], an exception [e] was caught and reported + on the error formatter (see the [~catch] parameter of {!eval}).}} *) + + val eval : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> ('a t * info) -> + 'a result + [@@ocaml.deprecated "Use Cmd.v and one of Cmd.eval* instead."] + (** [eval help err catch argv (t,i)] is the evaluation result + of [t] with command line arguments [argv] (defaults to {!Sys.argv}). + + If [catch] is [true] (default) uncaught exceptions + are intercepted and their stack trace is written to the [err] + formatter. + + [help] is the formatter used to print help or version messages + (defaults to {!Format.std_formatter}). [err] is the formatter + used to print error messages (defaults to {!Format.err_formatter}). + + [env] is used for environment variable lookup, the default + uses {!Sys.getenv}. *) + + val eval_choice : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + 'a t * info -> ('a t * info) list -> 'a result + [@@ocaml.deprecated "Use Cmd.group and one of Cmd.eval* instead."] + (** [eval_choice help err catch argv (t,i) choices] is like {!eval} + except that if the first argument on the command line is not an option + name it will look in [choices] for a term whose information has this + name and evaluate it. + + If the command name is unknown an error is reported. If the name + is unspecified the "main" term [t] is evaluated. [i] defines the + name and man page of the program. *) + + val eval_peek_opts : + ?version_opt:bool -> ?env:(string -> string option) -> + ?argv:string array -> 'a t -> 'a option * 'a result + [@@ocaml.deprecated "Use Cmd.eval_peek_opts instead."] + (** [eval_peek_opts version_opt argv t] evaluates [t], a term made + of optional arguments only, with the command line [argv] + (defaults to {!Sys.argv}). In this evaluation, unknown optional + arguments and positional arguments are ignored. + + The evaluation returns a pair. The first component is + the result of parsing the command line [argv] stripped from + any help and version option if [version_opt] is [true] (defaults + to [false]). It results in: + {ul + {- [Some _] if the command line would be parsed correctly given the + {e partial} knowledge in [t].} + {- [None] if a parse error would occur on the options of [t]}} + + The second component is the result of parsing the command line + [argv] without stripping the help and version options. It + indicates what the evaluation would result in on [argv] given + the partial knowledge in [t] (for example it would return + [`Help] if there's a help option in [argv]). However in + contrasts to {!eval} and {!eval_choice} no side effects like + error reporting or help output occurs. + + {b Note.} Positional arguments can't be peeked without the full + specification of the command line: we can't tell apart a + positional argument from the value of an unknown optional + argument. *) + + (** {2:exits Turning evaluation results into exit codes} + + {b Note.} If you are using the following functions to handle + the evaluation result of a term you should add {!default_exits} to + the term's information {{!val-info}[~exits]} argument. + + {b WARNING.} You should avoid status codes strictly greater than 125 + as those may be used by + {{:https://www.gnu.org/software/bash/manual/html_node/Exit-Status.html} + some} shells. *) + + val exit_status_success : int + [@@ocaml.deprecated "Use Cmd.Exit.ok instead."] + (** [exit_status_success] is 0, the exit status for success. *) + + val exit_status_cli_error : int + [@@ocaml.deprecated "Use Cmd.Exit.cli_error instead."] + (** [exit_status_cli_error] is 124, an exit status for command line + parsing errors. *) + + val exit_status_internal_error : int + [@@ocaml.deprecated "Use Cmd.Exit.internal_error instead."] + (** [exit_status_internal_error] is 125, an exit status for unexpected + internal errors. *) + + val exit_status_of_result : ?term_err:int -> unit result -> int + [@@ocaml.deprecated "Use Cmd.eval instead."] + (** [exit_status_of_result ~term_err r] is an [exit(3)] status + code determined from [r] as follows: + {ul + {- {!exit_status_success} if [r] is one of [`Ok ()], [`Version], [`Help]} + {- [term_err] if [r] is [`Error `Term], [term_err] defaults to [1].} + {- {!exit_status_cli_error} if [r] is [`Error `Parse]} + {- {!exit_status_internal_error} if [r] is [`Error `Exn]}} *) + + val exit_status_of_status_result : ?term_err:int -> int result -> int + [@@ocaml.deprecated "Use Cmd.eval' instead."] + (** [exit_status_of_status_result] is like {!exit_status_of_result} + except for [`Ok n] where [n] is used as the status exit code. *) + + val exit : ?term_err:int -> unit result -> unit + [@@ocaml.deprecated "Use Stdlib.exit and Cmd.eval instead."] + (** [exit ~term_err r] is + [Stdlib.exit @@ exit_status_of_result ~term_err r] *) + + val exit_status : ?term_err:int -> int result -> unit + [@@ocaml.deprecated "Use Stdlib.exit and Cmd.eval' instead."] + (** [exit_status ~term_err r] is + [Stdlib.exit @@ exit_status_of_status_result ~term_err r] *) + + (**/**) + val pure : 'a -> 'a t + [@@ocaml.deprecated "Use Term.const instead."] + (** @deprecated use {!const} instead. *) + + val man_format : Manpage.format t + [@@ocaml.deprecated "Use Arg.man_format instead."] + (** @deprecated Use {!Arg.man_format} instead. *) + (**/**) +end + +(** Commands. + + Command line syntaxes are implicitely defined by {!Term}s. A command + value binds a syntax and its documentation to a command name. + + A command can group a list of sub commands (and recursively). In this + case your tool defines a tree of commands, each with its own command + line syntax. The root of that tree is called the {e main command}; + it represents your tool and its name. *) +module Cmd : sig + + (** {1:info Command information} + + Command information defines the name and documentation of a command. *) + + (** Exit codes and their information. *) + module Exit : sig + + (** {1:codes Exit codes} *) + + type code = int + (** The type for exit codes. + + {b Warning.} You should avoid status codes strictly greater than 125 + as those may be used by + {{:https://www.gnu.org/software/bash/manual/html_node/Exit-Status.html} + some} shells. *) + + val ok : code + (** [ok] is [0], the exit status for success. *) + + val some_error : code + (** [some_error] is [123], an exit status for indisciminate errors + reported on stderr. *) + + val cli_error : code + (** [cli_error] is [124], an exit status for command line parsing + errors. *) + + val internal_error : code + (** [internal_error] is [125], an exit status for unexpected internal + errors. *) + + (** {1:info Exit code information} *) + + type info + (** The type for exit code information. *) + + val info : ?docs:string -> ?doc:string -> ?max:code -> code -> info + (** [exit_info ~docs ~doc min ~max] describe the range of exit + statuses from [min] to [max] (defaults to [min]). [doc] is the + man page information for the statuses, defaults to ["undocumented"]. + [docs] is the title of the man page section in which the statuses + will be listed, it defaults to {!Manpage.s_exit_status}. + + In [doc] the {{!page-tool_man.doclang}documentation markup language} + can be used with following variables: + {ul + {- [$(status)], the value of [min].} + {- [$(status_max)], the value of [max].} + {- The variables mentioned in the {!Cmd.val-info}}} *) + + val info_code : info -> code + (** [info_code i] is the minimal code of [i]. *) + + val defaults : info list + (** [defaults] are exit code information for {!ok}, {!some_error} + {!cli_error} and {!internal_error}. *) + end + + (** Environment variable and their information. *) + module Env : sig + + (** {1:envvars Environment variables} *) + + type var = string + (** The type for environment names. *) + + (** {1:info Environment variable information} *) + + [@@@alert "-deprecated"] + type info = Term.env_info (* because of Arg. *) + (** The type for environment variable information. *) + [@@@alert "+deprecated"] + + val info : ?deprecated:string -> ?docs:string -> ?doc:string -> var -> info + (** [info ~docs ~doc var] describes an environment variable + [var] such that: + {ul + {- [doc] is the man page information of the environment + variable, defaults to ["undocumented"].} + {- [docs] is the title of the man page section in which the environment + variable will be listed, it defaults to + {!Cmdliner.Manpage.s_environment}.} + {- [deprecated], if specified the environment is deprecated and the + string is a message output on standard error when the environment + variable gets used to lookup the default value of an argument.}} + In [doc] the {{!page-tool_man.doclang}documentation markup language} + can be used with following variables: + {ul + {- [$(env)], the value of [var].} + {- The variables mentioned in {!val-info}.}} *) + end + + type info + (** The type for information about commands. *) + + val info : + ?deprecated:string -> ?man_xrefs:Manpage.xref list -> + ?man:Manpage.block list -> ?envs:Env.info list -> ?exits:Exit.info list -> + ?sdocs:string -> ?docs:string -> ?doc:string -> ?version:string -> + string -> info + (** [info name ?sdocs ?man ?docs ?doc ?version] is a term information + such that: + {ul + {- [name] is the name of the command.} + {- [version] is the version string of the command line tool, this + is only relevant for the main command and ignored otherwise.} + {- [deprecated], if specified the command is deprecated and the + string is a message output on standard error when the command + is used.} + {- [doc] is a one line description of the command used + for the [NAME] section of the command's man page and in command + group listings.} + {- [docs], for commands that are part of a group, the title of the + section of the parent's command man page where it should be listed + (defaults to {!Manpage.s_commands}).} + {- [sdocs] defines the title of the section in which the + standard [--help] and [--version] arguments are listed + (defaults to {!Manpage.s_common_options}).} + {- [exits] is a list of exit statuses that the command evaluation + may produce, defaults to {!Exit.defaults}.} + {- [envs] is a list of environment variables that influence + the command's evaluation.} + {- [man] is the text of the man page for the command.} + {- [man_xrefs] are cross-references to other manual pages. These + are used to generate a {!Manpage.s_see_also} section.}} + + [doc], [man], [envs] support the {{!page-tool_man.doclang}documentation + markup language} in which the following variables are recognized: + {ul + {- [$(tname)] the (term's) command's name.} + {- [$(mname)] the main command name.}} *) + + (** {1:cmds Commands} *) + + type 'a t + (** The type for commands whose evaluation result in a value of + type ['a]. *) + + val v : info -> 'a Term.t -> 'a t + (** [v i t] is a command with information [i] and command line syntax + parsed by [t]. *) + + val group : ?default:'a Term.t -> info -> 'a t list -> 'a t + (** [group i ?default cmds] is a command with information [i] that + groups sub commands [cmds]. [default] is the command line syntax + to parse if no sub command is specified on the command line. If + [default] is [None] (default), the tool errors when no sub + command is specified. *) + + val name : 'a t -> string + (** [name c] is the name of [c]. *) + + (** {1:eval Evaluation} + + These functions are meant to be composed with {!Stdlib.exit}. + The following exit codes may be returned by all these functions: + {ul + {- {!Exit.cli_error} if a parse error occurs.} + {- {!Exit.internal_error} if the [~catch] argument is [true] (default) + and an uncaught exception is raised.} + {- The value of [~term_err] (defaults to {!Exit.cli_error}) if + a term error occurs.}} + + These exit codes are described in {!Exit.defaults} which is the + default value of the [?exits] argument of function {!val-info}. *) + + val eval : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:Exit.code -> unit t -> Exit.code + (** [eval cmd] is {!Exit.ok} if [cmd] evaluates to [()]. + See {!eval_value} for other arguments. *) + + val eval' : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:Exit.code -> Exit.code t -> Exit.code + (** [eval' cmd] is [c] if [cmd] evaluates to the exit code [c]. + See {!eval_value} for other arguments. *) + + val eval_result : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:Exit.code -> (unit, string) result t -> Exit.code + (** [eval_result cmd] is: + {ul + {- {!Exit.ok} if [cmd] evaluates to [Ok ()].} + {- {!Exit.some_error} if [cmd] evaluates to [Error msg]. In this + case [msg] is printed on [err].}} + See {!eval_value} for other arguments. *) + + val eval_result' : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:Exit.code -> (Exit.code, string) result t -> Exit.code + (** [eval_result' cmd] is: + {ul + {- [c] if [cmd] evaluates to [Ok c].} + {- {!Exit.some_error} if [cmd] evaluates to [Error msg]. In this + case [msg] is printed on [err].}} + See {!eval_value} for other arguments. *) + + (** {2:eval_low Low level evaluation} + + This interface gives more information on command evaluation results + and lets you choose how to map evaluation results to exit codes. *) + + type 'a eval_ok = + [ `Ok of 'a (** The term of the command evaluated to this value. *) + | `Version (** The version of the main cmd was requested. *) + | `Help (** Help was requested. *) ] + (** The type for successful evaluation results. *) + + type eval_error = + [ `Parse (** A parse error occured. *) + | `Term (** A term evaluation error occured. *) + | `Exn (** An uncaught exception occured. *) ] + (** The type for erroring evaluation results. *) + + val eval_value : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> 'a t -> + ('a eval_ok, eval_error) result + (** [eval ~help ~err ~catch ~env ~argv cmd] is the evaluation result + of [cmd] with: + {ul + {- [argv] the command line arguments to parse (defaults to {!Sys.argv})} + {- [env] the function used for environment variable lookup (defaults + to {!Sys.getenv}.} + {- [catch] if [true] (default) uncaught exceptions + are intercepted and their stack trace is written to the [err] + formatter} + {- [help] is the formatter used to print help or version messages + (defaults to {!Format.std_formatter})} + {- [err] is the formatter used to print error messages + (defaults to {!Format.err_formatter}.}} *) + + val eval_peek_opts : + ?version_opt:bool -> ?env:(string -> string option) -> + ?argv:string array -> 'a Term.t -> + 'a option * ('a eval_ok, eval_error) result + (** [eval_peek_opts version_opt argv t] evaluates [t], a term made + of optional arguments only, with the command line [argv] + (defaults to {!Sys.argv}). In this evaluation, unknown optional + arguments and positional arguments are ignored. + + The evaluation returns a pair. The first component is + the result of parsing the command line [argv] stripped from + any help and version option if [version_opt] is [true] (defaults + to [false]). It results in: + {ul + {- [Some _] if the command line would be parsed correctly given the + {e partial} knowledge in [t].} + {- [None] if a parse error would occur on the options of [t]}} + + The second component is the result of parsing the command line + [argv] without stripping the help and version options. It + indicates what the evaluation would result in on [argv] given + the partial knowledge in [t] (for example it would return + [`Help] if there's a help option in [argv]). However in + contrasts to {!val-eval_value} no side effects like error + reporting or help output occurs. + + {b Note.} Positional arguments can't be peeked without the full + specification of the command line: we can't tell apart a + positional argument from the value of an unknown optional + argument. *) +end + +(** Terms for command line arguments. + + This module provides functions to define terms that evaluate + to the arguments provided on the command line. + + Basic constraints, like the argument type or repeatability, are + specified by defining a value of type {!Arg.t}. Further constraints can + be specified during the {{!Arg.argterms}conversion} to a term. *) +module Arg : sig + +(** {1:argconv Argument converters} + + An argument converter transforms a string argument of the command + line to an OCaml value. {{!converters}Predefined converters} + are provided for many types of the standard library. *) + + type 'a parser = string -> [ `Ok of 'a | `Error of string ] + [@@ocaml.deprecated "Use Arg.conv or Arg.conv' instead."] + (** The type for argument parsers. + + {b Deprecated.} Use parser signatures of {!val-conv} or {!val-conv'}. *) + + type 'a printer = Format.formatter -> 'a -> unit + (** The type for converted argument printers. *) + + [@@@alert "-deprecated"] (* Need to be able to mention them ! *) + type 'a conv = 'a parser * 'a printer + (** The type for argument converters. + + {b Warning.} Do not use directly, use {!val-conv} or {!val-conv'}. + This type will become abstract in the next major version of cmdliner. *) + [@@@alert "+deprecated"] (* Need to be able to mention them ! *) + + val conv : + ?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a printer -> + 'a conv + (** [conv ~docv (parse, print)] is an argument converter + parsing values with [parse] and printing them with + [print]. [docv] is a documentation meta-variable used in the + documentation to stand for the argument value, defaults to + ["VALUE"]. *) + + val conv' : + ?docv:string -> (string -> ('a, string) result) * 'a printer -> + 'a conv + (** [conv'] is like {!val-conv} but the [Error] case has an unlabelled + string. *) + + val conv_parser : 'a conv -> (string -> ('a, [`Msg of string]) result) + (** [conv_parser c] is the parser of [c]. *) + + val conv_printer : 'a conv -> 'a printer + (** [conv_printer c] is the printer of [c]. *) + + val conv_docv : 'a conv -> string + (** [conv_docv c] is [c]'s documentation meta-variable. + + {b Warning.} Currently always returns ["VALUE"] in the future + will return the value given to {!val-conv} or {!val-conv'}. *) + + val parser_of_kind_of_string : + kind:string -> (string -> 'a option) -> + (string -> ('a, [`Msg of string]) result) + (** [parser_of_kind_of_string ~kind kind_of_string] is an argument + parser using the [kind_of_string] function for parsing and [kind] + to report errors (e.g. could be ["an integer"] for an [int] parser.). *) + + val some' : ?none:'a -> 'a conv -> 'a option conv + (** [some' ?none c] is like the converter [c] except it returns + [Some] value. It is used for command line arguments that default + to [None] when absent. If provided, [none] is used with [conv]'s + printer to document the value taken on absence; to document + a more complex behaviour use the [absent] argument of {!val-info}. *) + + val some : ?none:string -> 'a conv -> 'a option conv + (** [some ?none c] is like [some'] but [none] is described as a + string that will be rendered in bold. *) + +(** {1:arginfo Arguments and their information} + + Argument information defines the man page information of an + argument and, for optional arguments, its names. An environment + variable can also be specified to read the argument value from + if the argument is absent from the command line and the variable + is defined. *) + + type 'a t + (** The type for arguments holding data of type ['a]. *) + + type info + (** The type for information about command line arguments. *) + + val info : + ?deprecated:string -> ?absent:string -> ?docs:string -> ?docv:string -> + ?doc:string -> ?env:Cmd.Env.info -> string list -> info + (** [info docs docv doc env names] defines information for + an argument. + {ul + {- [names] defines the names under which an optional argument + can be referred to. Strings of length [1] (["c"]) define + short option names (["-c"]), longer strings (["count"]) + define long option names (["--count"]). [names] must be empty + for positional arguments.} + {- [env] defines the name of an environment variable which is + looked up for defining the argument if it is absent from the + command line. See {{!page-cli.envlookup}environment variables} for + details.} + {- [doc] is the man page information of the argument. + The {{!page-tool_man.doclang}documentation language} can be used and + the following variables are recognized: + {ul + {- ["$(docv)"] the value of [docv] (see below).} + {- ["$(opt)"], one of the options of [names], preference + is given to a long one.} + {- ["$(env)"], the environment var specified by [env] (if any).}} + {{!doc_helpers}These functions} can help with formatting argument + values.} + {- [docv] is for positional and non-flag optional arguments. + It is a variable name used in the man page to stand for their value.} + {- [docs] is the title of the man page section in which the argument + will be listed. For optional arguments this defaults + to {!Manpage.s_options}. For positional arguments this defaults + to {!Manpage.s_arguments}. However a positional argument is only + listed if it has both a [doc] and [docv] specified.} + {- [deprecated], if specified the argument is deprecated and the + string is a message output on standard error when the argument + is used.} + {- [absent], if specified a documentation string that indicates + what happens when the argument is absent. The document language + can be used like in [doc]. This overrides the automatic default + value rendering that is performed by the combinators.}} *) + + val ( & ) : ('a -> 'b) -> 'a -> 'b + (** [f & v] is [f v], a right associative composition operator for + specifying argument terms. *) + +(** {1:optargs Optional arguments} + + The information of an optional argument must have at least + one name or [Invalid_argument] is raised. *) + + val flag : info -> bool t + (** [flag i] is a [bool] argument defined by an optional flag + that may appear {e at most} once on the command line under one of + the names specified by [i]. The argument holds [true] if the + flag is present on the command line and [false] otherwise. *) + + val flag_all : info -> bool list t + (** [flag_all] is like {!flag} except the flag may appear more than + once. The argument holds a list that contains one [true] value per + occurrence of the flag. It holds the empty list if the flag + is absent from the command line. *) + + val vflag : 'a -> ('a * info) list -> 'a t + (** [vflag v \[v]{_0}[,i]{_0}[;…\]] is an ['a] argument defined + by an optional flag that may appear {e at most} once on + the command line under one of the names specified in the [i]{_k} + values. The argument holds [v] if the flag is absent from the + command line and the value [v]{_k} if the name under which it appears + is in [i]{_k}. + + {b Note.} Environment variable lookup is unsupported for + for these arguments. *) + + val vflag_all : 'a list -> ('a * info) list -> 'a list t + (** [vflag_all v l] is like {!vflag} except the flag may appear more + than once. The argument holds the list [v] if the flag is absent + from the command line. Otherwise it holds a list that contains one + corresponding value per occurrence of the flag, in the order found on + the command line. + + {b Note.} Environment variable lookup is unsupported for + for these arguments. *) + + val opt : ?vopt:'a -> 'a conv -> 'a -> info -> 'a t + (** [opt vopt c v i] is an ['a] argument defined by the value of + an optional argument that may appear {e at most} once on the command + line under one of the names specified by [i]. The argument holds + [v] if the option is absent from the command line. Otherwise + it has the value of the option as converted by [c]. + + If [vopt] is provided the value of the optional argument is itself + optional, taking the value [vopt] if unspecified on the command line. *) + + val opt_all : ?vopt:'a -> 'a conv -> 'a list -> info -> 'a list t + (** [opt_all vopt c v i] is like {!opt} except the optional argument may + appear more than once. The argument holds a list that contains one value + per occurrence of the flag in the order found on the command line. + It holds the list [v] if the flag is absent from the command line. *) + + (** {1:posargs Positional arguments} + + The information of a positional argument must have no name + or [Invalid_argument] is raised. Positional arguments indexing + is zero-based. + + {b Warning.} The following combinators allow to specify and + extract a given positional argument with more than one term. + This should not be done as it will likely confuse end users and + documentation generation. These over-specifications may be + prevented by raising [Invalid_argument] in the future. But for now + it is the client's duty to make sure this doesn't happen. *) + + val pos : ?rev:bool -> int -> 'a conv -> 'a -> info -> 'a t + (** [pos rev n c v i] is an ['a] argument defined by the [n]th + positional argument of the command line as converted by [c]. + If the positional argument is absent from the command line + the argument is [v]. + + If [rev] is [true] (defaults to [false]), the computed + position is [max-n] where [max] is the position of + the last positional argument present on the command line. *) + + val pos_all : 'a conv -> 'a list -> info -> 'a list t + (** [pos_all c v i] is an ['a list] argument that holds + all the positional arguments of the command line as converted + by [c] or [v] if there are none. *) + + val pos_left : + ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t + (** [pos_left rev n c v i] is an ['a list] argument that holds + all the positional arguments as converted by [c] found on the left + of the [n]th positional argument or [v] if there are none. + + If [rev] is [true] (defaults to [false]), the computed + position is [max-n] where [max] is the position of + the last positional argument present on the command line. *) + + val pos_right : + ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t + (** [pos_right] is like {!pos_left} except it holds all the positional + arguments found on the right of the specified positional argument. *) + + (** {1:argterms Arguments as terms} *) + + val value : 'a t -> 'a Term.t + (** [value a] is a term that evaluates to [a]'s value. *) + + val required : 'a option t -> 'a Term.t + (** [required a] is a term that fails if [a]'s value is [None] and + evaluates to the value of [Some] otherwise. Use this for required + positional arguments (it can also be used for defining required + optional arguments, but from a user interface perspective this + shouldn't be done, it is a contradiction in terms). *) + + val non_empty : 'a list t -> 'a list Term.t + (** [non_empty a] is term that fails if [a]'s list is empty and + evaluates to [a]'s list otherwise. Use this for non empty lists + of positional arguments. *) + + val last : 'a list t -> 'a Term.t + (** [last a] is a term that fails if [a]'s list is empty and evaluates + to the value of the last element of the list otherwise. Use this + for lists of flags or options where the last occurrence takes precedence + over the others. *) + + (** {1:predef Predefined arguments} *) + + val man_format : Manpage.format Term.t + (** [man_format] is a term that defines a [--man-format] option and + evaluates to a value that can be used with {!Manpage.print}. *) + + (** {1:converters Predefined converters} *) + + val bool : bool conv + (** [bool] converts values with {!bool_of_string}. *) + + val char : char conv + (** [char] converts values by ensuring the argument has a single char. *) + + val int : int conv + (** [int] converts values with {!int_of_string}. *) + + val nativeint : nativeint conv + (** [nativeint] converts values with {!Nativeint.of_string}. *) + + val int32 : int32 conv + (** [int32] converts values with {!Int32.of_string}. *) + + val int64 : int64 conv + (** [int64] converts values with {!Int64.of_string}. *) + + val float : float conv + (** [float] converts values with {!float_of_string}. *) + + val string : string conv + (** [string] converts values with the identity function. *) + + val enum : (string * 'a) list -> 'a conv + (** [enum l p] converts values such that unambiguous prefixes of string names + in [l] map to the corresponding value of type ['a]. + + {b Warning.} The type ['a] must be comparable with {!Stdlib.compare}. + + @raise Invalid_argument if [l] is empty. *) + + val file : string conv + (** [file] converts a value with the identity function and + checks with {!Sys.file_exists} that a file with that name exists. *) + + val dir : string conv + (** [dir] converts a value with the identity function and checks + with {!Sys.file_exists} and {!Sys.is_directory} + that a directory with that name exists. *) + + val non_dir_file : string conv + (** [non_dir_file] converts a value with the identity function and checks + with {!Sys.file_exists} and {!Sys.is_directory} + that a non directory file with that name exists. *) + + val list : ?sep:char -> 'a conv -> 'a list conv + (** [list sep c] splits the argument at each [sep] (defaults to [',']) + character and converts each substrings with [c]. *) + + val array : ?sep:char -> 'a conv -> 'a array conv + (** [array sep c] splits the argument at each [sep] (defaults to [',']) + character and converts each substring with [c]. *) + + val pair : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv + (** [pair sep c0 c1] splits the argument at the {e first} [sep] character + (defaults to [',']) and respectively converts the substrings with + [c0] and [c1]. *) + + val t2 : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv + (** {!t2} is {!pair}. *) + + val t3 : ?sep:char -> 'a conv ->'b conv -> 'c conv -> ('a * 'b * 'c) conv + (** [t3 sep c0 c1 c2] splits the argument at the {e first} two [sep] + characters (defaults to [',']) and respectively converts the + substrings with [c0], [c1] and [c2]. *) + + val t4 : + ?sep:char -> 'a conv -> 'b conv -> 'c conv -> 'd conv -> + ('a * 'b * 'c * 'd) conv + (** [t4 sep c0 c1 c2 c3] splits the argument at the {e first} three [sep] + characters (defaults to [',']) respectively converts the substrings + with [c0], [c1], [c2] and [c3]. *) + + (** {1:doc_helpers Documentation formatting helpers} *) + + val doc_quote : string -> string + (** [doc_quote s] quotes the string [s]. *) + + val doc_alts : ?quoted:bool -> string list -> string + (** [doc_alts alts] documents the alternative tokens [alts] + according the number of alternatives. If [quoted] is: + {ul + {- [None], the tokens are enclosed in manpage markup directives + to render them in bold (manpage convention).} + {- [Some true], the tokens are quoted with {!doc_quote}.} + {- [Some false], the tokens are written as is}} + The resulting string can be used in sentences of + the form ["$(docv) must be %s"]. + + @raise Invalid_argument if [alts] is the empty list. *) + + val doc_alts_enum : ?quoted:bool -> (string * 'a) list -> string + (** [doc_alts_enum quoted alts] is [doc_alts quoted (List.map fst alts)]. *) + + (** {1:deprecated Deprecated} *) + + [@@@alert "-deprecated"] + + type 'a converter = 'a conv + [@@ocaml.deprecated "Use Arg.conv' function instead."] + (** See {!Arg.conv'}. *) + + val pconv : + ?docv:string -> 'a parser * 'a printer -> 'a conv + [@@ocaml.deprecated "Use Arg.conv or Arg.conv' function instead."] + (** [pconv] is like {!val-conv} or {!val-conv'}, but uses a + deprecated {!parser} signature. *) + + + type env = Cmd.Env.info + [@@ocaml.deprecated "Use Cmd.Env.info instead."] + (** See {!Cmd.Env.type-info} *) + + val env_var : + ?deprecated:string -> ?docs:string -> ?doc:string -> Cmd.Env.var -> + Cmd.Env.info + [@@ocaml.deprecated "Use Cmd.Env.info instead."] + (** See {!Cmd.Env.val-info}. *) +end + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner.mllib b/src/cmdliner.mllib new file mode 100644 index 0000000..fd479c0 --- /dev/null +++ b/src/cmdliner.mllib @@ -0,0 +1,12 @@ +Cmdliner_trie +Cmdliner_base +Cmdliner_manpage +Cmdliner_info +Cmdliner_docgen +Cmdliner_msg +Cmdliner_cline +Cmdliner_arg +Cmdliner_term +Cmdliner_cmd +Cmdliner_eval +Cmdliner diff --git a/src/cmdliner_arg.ml b/src/cmdliner_arg.ml new file mode 100644 index 0000000..56d1fb6 --- /dev/null +++ b/src/cmdliner_arg.ml @@ -0,0 +1,377 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +let rev_compare n0 n1 = compare n1 n0 + +(* Invalid_argument strings **) + +let err_not_opt = "Option argument without name" +let err_not_pos = "Positional argument with a name" + +(* Documentation formatting helpers *) + +let strf = Printf.sprintf +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 () + +(* Argument converters *) + +type 'a parser = string -> [ `Ok of 'a | `Error of string ] +type 'a printer = Format.formatter -> 'a -> unit + +type 'a conv = 'a parser * 'a printer +type 'a converter = 'a conv + +let default_docv = "VALUE" +let conv ?docv (parse, print) = + let parse s = match parse s with Ok v -> `Ok v | Error (`Msg e) -> `Error e in + parse, print + +let conv' ?docv (parse, print) = + let parse s = match parse s with Ok v -> `Ok v | Error e -> `Error e in + parse, print + +let pconv ?docv conv = conv + +let conv_parser (parse, _) = + fun s -> match parse s with `Ok v -> Ok v | `Error e -> Error (`Msg e) + +let conv_printer (_, print) = print +let conv_docv _ = default_docv + +let err_invalid s kind = `Msg (strf "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 + +let some = Cmdliner_base.some +let some' = Cmdliner_base.some' + +(* Argument information *) + +type env = Cmdliner_info.Env.info +let env_var = Cmdliner_info.Env.info + +type 'a t = 'a Cmdliner_term.t +type info = Cmdliner_info.Arg.t +let info = Cmdliner_info.Arg.v + +(* Arguments *) + +let ( & ) f x = f x + +let err e = Error (`Parse e) + +let parse_to_list parser s = match parser s with +| `Ok v -> `Ok [v] +| `Error _ as e -> e + +let report_deprecated_env ei e = match Cmdliner_info.Env.info_deprecated e with +| None -> () +| Some msg -> + let var = Cmdliner_info.Env.info_var e in + let msg = String.concat "" ["environment variable "; var; ": "; msg ] in + let err_fmt = Cmdliner_info.Eval.err_ppf ei in + Cmdliner_msg.pp_err err_fmt ei ~err:msg + +let try_env ei a parse ~absent = match Cmdliner_info.Arg.env a with +| None -> Ok absent +| Some env -> + let var = Cmdliner_info.Env.info_var env in + match Cmdliner_info.Eval.env_var ei var with + | None -> Ok absent + | Some v -> + match parse v with + | `Error e -> err (Cmdliner_msg.err_env_parse env ~err:e) + | `Ok v -> report_deprecated_env ei env; Ok v + +let arg_to_args = Cmdliner_info.Arg.Set.singleton +let list_to_args f l = + let add acc v = Cmdliner_info.Arg.Set.add (f v) acc in + List.fold_left add Cmdliner_info.Arg.Set.empty l + +let flag a = + if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else + let convert ei cl = match Cmdliner_cline.opt_arg cl a with + | [] -> try_env ei a Cmdliner_base.env_bool_parse ~absent:false + | [_, _, None] -> Ok true + | [_, f, Some v] -> err (Cmdliner_msg.err_flag_value f v) + | (_, f, _) :: (_ ,g, _) :: _ -> err (Cmdliner_msg.err_opt_repeated f g) + in + arg_to_args a, convert + +let flag_all a = + if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else + let a = Cmdliner_info.Arg.make_all_opts a in + let convert ei cl = match Cmdliner_cline.opt_arg cl a with + | [] -> + try_env ei a (parse_to_list Cmdliner_base.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 -> err e + in + arg_to_args a, convert + +let vflag v l = + let convert _ cl = + let rec aux fv = function + | (v, a) :: rest -> + begin match Cmdliner_cline.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 -> err e + in + let flag (_, a) = + if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else a + in + list_to_args flag l, convert + +let vflag_all v l = + let convert _ cl = + let rec aux acc = function + | (fv, a) :: rest -> + begin match Cmdliner_cline.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 -> err e + in + let flag (_, a) = + if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else + Cmdliner_info.Arg.make_all_opts a + in + list_to_args flag l, 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 (parse, print) v a = + if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else + let absent = match Cmdliner_info.Arg.absent a with + | Cmdliner_info.Arg.Doc d as a when d <> "" -> a + | _ -> Cmdliner_info.Arg.Val (lazy (str_of_pp print v)) + in + let kind = match vopt with + | None -> Cmdliner_info.Arg.Opt + | Some dv -> Cmdliner_info.Arg.Opt_vopt (str_of_pp print dv) + in + let a = Cmdliner_info.Arg.make_opt ~absent ~kind a in + let convert ei cl = match Cmdliner_cline.opt_arg cl a with + | [] -> try_env ei a parse ~absent:v + | [_, f, Some v] -> + (try Ok (parse_opt_value parse f v) with Failure e -> err e) + | [_, f, None] -> + begin match vopt with + | None -> err (Cmdliner_msg.err_opt_value_missing f) + | Some optv -> Ok optv + end + | (_, f, _) :: (_, g, _) :: _ -> err (Cmdliner_msg.err_opt_repeated g f) + in + arg_to_args a, convert + +let opt_all ?vopt (parse, print) v a = + if Cmdliner_info.Arg.is_pos a then invalid_arg err_not_opt else + let absent = match Cmdliner_info.Arg.absent a with + | Cmdliner_info.Arg.Doc d as a when d <> "" -> a + | _ -> Cmdliner_info.Arg.Val (lazy "") + in + let kind = match vopt with + | None -> Cmdliner_info.Arg.Opt + | Some dv -> Cmdliner_info.Arg.Opt_vopt (str_of_pp print dv) + in + let a = Cmdliner_info.Arg.make_opt_all ~absent ~kind a in + let convert ei cl = match Cmdliner_cline.opt_arg cl a with + | [] -> try_env ei a (parse_to_list parse) ~absent:v + | l -> + let parse (k, f, v) = match v with + | Some v -> (k, parse_opt_value parse 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 -> err e + in + arg_to_args a, 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 (parse, print) v a = + if Cmdliner_info.Arg.is_opt a then invalid_arg err_not_pos else + let absent = match Cmdliner_info.Arg.absent a with + | Cmdliner_info.Arg.Doc d as a when d <> "" -> a + | _ -> Cmdliner_info.Arg.Val (lazy (str_of_pp print v)) + in + let pos = Cmdliner_info.Arg.pos ~rev ~start:k ~len:(Some 1) in + let a = Cmdliner_info.Arg.make_pos_abs ~absent ~pos a in + let convert ei cl = match Cmdliner_cline.pos_arg cl a with + | [] -> try_env ei a parse ~absent:v + | [v] -> + (try Ok (parse_pos_value parse a v) with Failure e -> err e) + | _ -> assert false + in + arg_to_args a, convert + +let pos_list pos (parse, _) v a = + if Cmdliner_info.Arg.is_opt a then invalid_arg err_not_pos else + let a = Cmdliner_info.Arg.make_pos ~pos a in + let convert ei cl = match Cmdliner_cline.pos_arg cl a with + | [] -> try_env ei a (parse_to_list parse) ~absent:v + | l -> + try Ok (List.rev (List.rev_map (parse_pos_value parse a) l)) with + | Failure e -> err e + in + arg_to_args a, convert + +let all = Cmdliner_info.Arg.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_info.Arg.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_info.Arg.pos ~rev ~start ~len) + +(* Arguments as terms *) + +let absent_error args = + let make_req a acc = + let req_a = Cmdliner_info.Arg.make_req a in + Cmdliner_info.Arg.Set.add req_a acc + in + Cmdliner_info.Arg.Set.fold make_req args Cmdliner_info.Arg.Set.empty + +let value a = a + +let err_arg_missing args = + err @@ Cmdliner_msg.err_arg_missing (Cmdliner_info.Arg.Set.choose args) + +let required (args, convert) = + let args = absent_error args in + let convert ei cl = match convert ei cl with + | Ok (Some v) -> Ok v + | Ok None -> err_arg_missing args + | Error _ as e -> e + in + args, convert + +let non_empty (al, convert) = + let args = absent_error al in + let convert ei cl = match convert ei cl with + | Ok [] -> err_arg_missing args + | Ok l -> Ok l + | Error _ as e -> e + in + args, convert + +let last (args, convert) = + let convert ei cl = match convert ei cl with + | Ok [] -> err_arg_missing args + | Ok l -> Ok (List.hd (List.rev l)) + | Error _ as e -> e + in + args, convert + +(* Predefined arguments *) + +let man_fmts = + ["auto", `Auto; "pager", `Pager; "groff", `Groff; "plain", `Plain] + +let man_fmt_docv = "FMT" +let man_fmts_enum = Cmdliner_base.enum man_fmts +let man_fmts_alts = doc_alts_enum man_fmts +let man_fmts_doc kind = + strf "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 + +(* Predefined converters. *) + +let bool = Cmdliner_base.bool +let char = Cmdliner_base.char +let int = Cmdliner_base.int +let nativeint = Cmdliner_base.nativeint +let int32 = Cmdliner_base.int32 +let int64 = Cmdliner_base.int64 +let float = Cmdliner_base.float +let string = Cmdliner_base.string +let enum = Cmdliner_base.enum +let file = Cmdliner_base.file +let dir = Cmdliner_base.dir +let non_dir_file = Cmdliner_base.non_dir_file +let list = Cmdliner_base.list +let array = Cmdliner_base.array +let pair = Cmdliner_base.pair +let t2 = Cmdliner_base.t2 +let t3 = Cmdliner_base.t3 +let t4 = Cmdliner_base.t4 + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_arg.mli b/src/cmdliner_arg.mli new file mode 100644 index 0000000..e3faa2f --- /dev/null +++ b/src/cmdliner_arg.mli @@ -0,0 +1,115 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(** Command line arguments as terms. *) + +type 'a parser = string -> [ `Ok of 'a | `Error of string ] +type 'a printer = Format.formatter -> 'a -> unit +type 'a conv = 'a parser * 'a printer +type 'a converter = 'a conv + +val conv : + ?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a printer -> + 'a conv + +val conv' : + ?docv:string -> (string -> ('a, string) result) * 'a printer -> 'a conv + +val pconv : ?docv:string -> 'a parser * 'a printer -> '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) + +val some : ?none:string -> 'a converter -> 'a option converter +val some' : ?none:'a -> 'a converter -> 'a option converter + +type env = Cmdliner_info.Env.info +val env_var : ?deprecated:string -> ?docs:string -> ?doc:string -> string -> env + +type 'a t = 'a Cmdliner_term.t + +type info +val info : + ?deprecated:string -> ?absent:string -> ?docs:string -> ?docv:string -> + ?doc:string -> ?env:env -> 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 converter -> 'a -> info -> 'a t +val opt_all : ?vopt:'a -> 'a converter -> 'a list -> info -> 'a list t + +val pos : ?rev:bool -> int -> 'a converter -> 'a -> info -> 'a t +val pos_all : 'a converter -> 'a list -> info -> 'a list t +val pos_left : ?rev:bool -> int -> 'a converter -> 'a list -> info -> 'a list t +val pos_right : ?rev:bool -> int -> 'a converter -> 'a list -> info -> 'a list t + +(** {1 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 + +(** {1 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 + +(** {1 Converters} *) + +val bool : bool converter +val char : char converter +val int : int converter +val nativeint : nativeint converter +val int32 : int32 converter +val int64 : int64 converter +val float : float converter +val string : string converter +val enum : (string * 'a) list -> 'a converter +val file : string converter +val dir : string converter +val non_dir_file : string converter +val list : ?sep:char -> 'a converter -> 'a list converter +val array : ?sep:char -> 'a converter -> 'a array converter +val pair : ?sep:char -> 'a converter -> 'b converter -> ('a * 'b) converter +val t2 : ?sep:char -> 'a converter -> 'b converter -> ('a * 'b) converter + +val t3 : + ?sep:char -> 'a converter ->'b converter -> 'c converter -> + ('a * 'b * 'c) converter + +val t4 : + ?sep:char -> 'a converter ->'b converter -> 'c converter -> 'd converter -> + ('a * 'b * 'c * 'd) converter + +val doc_quote : string -> string +val doc_alts : ?quoted:bool -> string list -> string +val doc_alts_enum : ?quoted:bool -> (string * 'a) list -> string + + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_base.ml b/src/cmdliner_base.ml new file mode 100644 index 0000000..c1a4d21 --- /dev/null +++ b/src/cmdliner_base.ml @@ -0,0 +1,357 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +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 *) + +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 [] + +(* Invalid argument strings *) + +let err_empty_list = "empty list" +let err_incomplete_enum ss = + strf "Arg.enum: missing printable string for a value, other strings are: %s" + (String.concat ", " ss) + +(* Formatting tools *) + +let pp = Format.fprintf +let pp_sp = Format.pp_print_space +let pp_str = Format.pp_print_string +let pp_char = Format.pp_print_char +let pp_text = Format.pp_print_text +let pp_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 pp_tokens ~spaces ppf s = (* collapse white and hint spaces (maybe) *) + let is_space = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false in + let i_max = String.length s - 1 in + let flush start stop = pp_str 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 pp_sp ppf () else pp_char ppf ' '; + if next_start > i_max then () else loop next_start next_start) + in + loop 0 0 + +(* Converter (end-user) error messages *) + +let quote s = strf "'%s'" s +let alts_str ?quoted alts = + let quote = match quoted with + | None -> strf "$(b,%s)" + | Some quoted -> if quoted then quote else (fun s -> s) + in + match alts with + | [] -> invalid_arg err_empty_list + | [a] -> (quote a) + | [a; b] -> strf "either %s or %s" (quote a) (quote b) + | alts -> + let rev_alts = List.rev alts in + strf "one of %s or %s" + (String.concat ", " (List.rev_map quote (List.tl rev_alts))) + (quote (List.hd rev_alts)) + +let err_multi_def ~kind name doc v v' = + strf "%s %s defined twice (doc strings are '%s' and '%s')" + kind name (doc v) (doc v') + +let err_ambiguous ~kind s ~ambs = + strf "%s %s ambiguous and could be %s" kind (quote s) + (alts_str ~quoted:true ambs) + +let err_unknown ?(dom = []) ?(hints = []) ~kind v = + let hints = match hints, dom with + | [], [] -> "." + | [], dom -> strf ", must be %s." (alts_str ~quoted:true dom) + | hints, _ -> strf ", did you mean %s?" (alts_str ~quoted:true hints) + in + strf "unknown %s %s%s" kind (quote v) hints + +let err_no kind s = strf "no %s %s" (quote s) kind +let err_not_dir s = strf "%s is not a directory" (quote s) +let err_is_dir s = strf "%s is a directory" (quote s) +let err_element kind s exp = + strf "invalid element in %s ('%s'): %s" kind s exp + +let err_invalid kind s exp = strf "invalid %s %s, %s" kind (quote s) exp +let err_invalid_val = err_invalid "value" +let err_sep_miss sep s = + err_invalid_val s (strf "missing a '%c' separator" sep) + +(* Converters *) + +type 'a parser = string -> [ `Ok of 'a | `Error of string ] +type 'a printer = Format.formatter -> 'a -> unit +type 'a conv = 'a parser * 'a printer + +let some ?(none = "") (parse, print) = + let parse s = match parse s with `Ok v -> `Ok (Some v) | `Error _ as e -> e in + let print ppf v = match v with + | None -> Format.pp_print_string ppf none + | Some v -> print ppf v + in + parse, print + +let some' ?none (parse, print) = + let parse s = match parse s with `Ok v -> `Ok (Some v) | `Error _ as e -> e in + let print ppf = function + | None -> (match none with None -> () | Some v -> print ppf v) + | Some v -> print ppf v + in + parse, print + +let bool = + let parse s = try `Ok (bool_of_string s) with + | Invalid_argument _ -> + `Error (err_invalid_val s (alts_str ~quoted:true ["true"; "false"])) + in + parse, Format.pp_print_bool + +let char = + let parse s = match String.length s = 1 with + | true -> `Ok s.[0] + | false -> `Error (err_invalid_val s "expected a character") + in + parse, pp_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 = + parse_with int_of_string "expected an integer", Format.pp_print_int + +let int32 = + parse_with Int32.of_string "expected a 32-bit integer", + (fun ppf -> pp ppf "%ld") + +let int64 = + parse_with Int64.of_string "expected a 64-bit integer", + (fun ppf -> pp ppf "%Ld") + +let nativeint = + parse_with Nativeint.of_string "expected a processor-native integer", + (fun ppf -> pp ppf "%nd") + +let float = + parse_with float_of_string "expected a floating point number", + Format.pp_print_float + +let string = (fun s -> `Ok s), pp_str +let enum sl = + if sl = [] then invalid_arg err_empty_list else + let t = Cmdliner_trie.of_list sl in + let parse s = match Cmdliner_trie.find t s with + | `Ok _ as r -> r + | `Ambiguous -> + let ambs = List.sort compare (Cmdliner_trie.ambiguities t s) in + `Error (err_ambiguous ~kind:"enum value" s ~ambs) + | `Not_found -> + let alts = List.rev (List.rev_map (fun (s, _) -> s) sl) in + `Error (err_invalid_val s ("expected " ^ (alts_str ~quoted:true alts))) + in + let print ppf v = + let sl_inv = List.rev_map (fun (s,v) -> (v,s)) sl in + try pp_str ppf (List.assoc v sl_inv) + with Not_found -> invalid_arg (err_incomplete_enum (List.map fst sl)) + in + parse, print + +let file = + let parse s = match Sys.file_exists s with + | true -> `Ok s + | false -> `Error (err_no "file or directory" s) + in + parse, pp_str + +let dir = + let parse s = match Sys.file_exists s with + | true -> if Sys.is_directory s then `Ok s else `Error (err_not_dir s) + | false -> `Error (err_no "directory" s) + in + parse, pp_str + +let non_dir_file = + let parse s = match Sys.file_exists s with + | true -> if not (Sys.is_directory s) then `Ok s else `Error (err_is_dir s) + | false -> `Error (err_no "file" s) + in + parse, pp_str + +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 = ',') (parse, pp_e) = + let parse s = try `Ok (split_and_parse sep parse s) with + | Failure e -> `Error (err_element "list" s e) + in + let rec print ppf = function + | v :: l -> pp_e ppf v; if (l <> []) then (pp_char ppf sep; print ppf l) + | [] -> () + in + parse, print + +let array ?(sep = ',') (parse, pp_e) = + let parse s = try `Ok (Array.of_list (split_and_parse sep parse s)) with + | Failure e -> `Error (err_element "array" s e) + in + let print ppf v = + let max = Array.length v - 1 in + for i = 0 to max do pp_e ppf v.(i); if i <> max then pp_char ppf sep done + in + parse, print + +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 = ',') (pa0, pr0) (pa1, pr1) = + let parser s = match split_left sep s with + | None -> `Error (err_sep_miss sep s) + | Some (v0, v1) -> + match pa0 v0, pa1 v1 with + | `Ok v0, `Ok v1 -> `Ok (v0, v1) + | `Error e, _ | _, `Error e -> `Error (err_element "pair" s e) + in + let printer ppf (v0, v1) = pp ppf "%a%c%a" pr0 v0 sep pr1 v1 in + parser, printer + +let t2 = pair +let t3 ?(sep = ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) = + let parse 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 pa0 v0, pa1 v1, pa2 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 print ppf (v0, v1, v2) = + pp ppf "%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2 + in + parse, print + +let t4 ?(sep = ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) (pa3, pr3) = + let parse 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 pa0 v0, pa1 v1, pa2 v2, pa3 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 print ppf (v0, v1, v2, v3) = + pp ppf "%a%c%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2 sep pr3 v3 + in + parse, print + +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 = alts_str ~quoted:true ["true"; "yes"; "false"; "no" ] in + `Error (err_invalid_val s alts) + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_base.mli b/src/cmdliner_base.mli new file mode 100644 index 0000000..2c3f3d9 --- /dev/null +++ b/src/cmdliner_base.mli @@ -0,0 +1,76 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(** 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]. *) + +(** {1:fmt Formatting helpers} *) + +val pp_text : Format.formatter -> string -> unit +val pp_lines : Format.formatter -> string -> unit +val pp_tokens : spaces:bool -> Format.formatter -> string -> unit + +(** {1:err Error message helpers} *) + +val quote : string -> string +val alts_str : ?quoted:bool -> string 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 + +(** {1:conv Textual OCaml value converters} *) + +type 'a parser = string -> [ `Ok of 'a | `Error of string ] +type 'a printer = Format.formatter -> 'a -> unit +type 'a conv = 'a parser * 'a printer + +val some : ?none:string -> 'a conv -> 'a option conv +val some' : ?none:'a -> 'a conv -> 'a option conv +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 : (string * 'a) list -> 'a 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 env_bool_parse : bool parser + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_cline.ml b/src/cmdliner_cline.ml new file mode 100644 index 0000000..5bff9d8 --- /dev/null +++ b/src/cmdliner_cline.ml @@ -0,0 +1,219 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(* A command line stores pre-parsed information about the command + line's arguments in a more structured way. Given the + Cmdliner_info.arg values mentioned in a term and Sys.argv + (without exec name) we parse the command line into a map of + Cmdliner_info.arg values to [arg] values (see below). This map is used by + the term's closures to retrieve and convert command line arguments + (see the Cmdliner_arg module). *) + +let err_multi_opt_name_def name a a' = + Cmdliner_base.err_multi_def + ~kind:"option name" name Cmdliner_info.Arg.doc a a' + +module Amap = Map.Make (Cmdliner_info.Arg) + +type 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 + +type t = arg Amap.t (* command line, maps arg_infos to arg value. *) + +let get_arg cl a = try Amap.find a cl with Not_found -> assert false +let opt_arg cl a = match get_arg cl a with O l -> l | _ -> assert false +let pos_arg cl a = match get_arg cl a with P l -> l | _ -> assert false +let actual_args cl a = match get_arg cl 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) + +let arg_info_indexes args = + (* 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 cmdline mapping each arg_info to an empty [arg]. *) + let rec loop optidx posidx cl = function + | [] -> optidx, posidx, cl + | a :: l -> + match Cmdliner_info.Arg.is_pos a with + | true -> loop optidx (a :: posidx) (Amap.add a (P []) cl) l + | false -> + let add t name = match Cmdliner_trie.add t name a with + | `New t -> t + | `Replaced (a', _) -> invalid_arg (err_multi_opt_name_def name a a') + in + let names = Cmdliner_info.Arg.opt_names a in + let optidx = List.fold_left add optidx names in + loop optidx posidx (Amap.add a (O []) cl) l + in + loop Cmdliner_trie.empty [] Amap.empty (Cmdliner_info.Arg.Set.elements args) + +(* Optional argument parsing *) + +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. *) + let l = String.length s in + if s.[1] <> '-' then (* short opt *) + if l = 2 then s, None else + String.sub s 0 2, Some (String.sub s 2 (l - 2)) (* with glued opt arg *) + else try (* long opt *) + let i = String.index s '=' in + String.sub s 0 i, Some (String.sub s (i + 1) (l - i - 1)) + with Not_found -> s, None + +let hint_matching_opt optidx s = + (* hint options that could match [s] in [optidx]. FIXME explain this is + a bit obscure. *) + 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_args ~peek_opts optidx cl args = + (* returns an updated [cl] 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 cl pargs = function + | [] -> List.rev errs, cl, List.rev pargs + | "--" :: args -> List.rev errs, cl, (List.rev_append pargs args) + | s :: args -> + if not (is_opt s) then loop errs (k + 1) cl (s :: pargs) args else + let name, value = parse_opt_arg s in + match Cmdliner_trie.find optidx name with + | `Ok a -> + let value, args = match value, Cmdliner_info.Arg.opt_kind a with + | Some v, Cmdliner_info.Arg.Flag when is_short_opt name -> + None, ("-" ^ v) :: args + | Some _, _ -> value, args + | None, Cmdliner_info.Arg.Flag -> value, args + | None, _ -> + match args with + | [] -> None, args + | v :: rest -> if is_opt v then None, args else Some v, rest + in + let arg = O ((k, name, value) :: opt_arg cl a) in + loop errs (k + 1) (Amap.add a arg cl) pargs args + | `Not_found when peek_opts -> loop errs (k + 1) cl pargs args + | `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) cl pargs args + | `Ambiguous -> + 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) cl pargs args + in + let errs, cl, pargs = loop [] 0 cl [] args in + if errs = [] then Ok (cl, pargs) else + let err = String.concat "\n" errs in + Error (err, cl, pargs) + +let take_range start stop l = + let rec loop i acc = function + | [] -> List.rev acc + | v :: vs -> + if i < start then loop (i + 1) acc vs else + if i <= stop then loop (i + 1) (v :: acc) vs else + List.rev acc + in + loop 0 [] l + +let process_pos_args posidx cl pargs = + (* returns an updated [cl] 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_info.Arg.is_req posidx in + if misses = [] then Ok cl else + Error (Cmdliner_msg.err_pos_misses misses, cl) + else + let last = List.length pargs - 1 in + let pos rev k = if rev then last - k else k in + let rec loop misses cl max_spec = function + | [] -> misses, cl, max_spec + | a :: al -> + let apos = Cmdliner_info.Arg.pos_kind a in + let rev = Cmdliner_info.Arg.pos_rev apos in + let start = pos rev (Cmdliner_info.Arg.pos_start apos) in + let stop = match Cmdliner_info.Arg.pos_len apos with + | None -> pos rev last + | Some n -> pos rev (Cmdliner_info.Arg.pos_start apos + n - 1) + in + let start, stop = if rev then stop, start else start, stop in + let args = take_range start stop pargs in + let max_spec = max stop max_spec in + let cl = Amap.add a (P args) cl in + let misses = match Cmdliner_info.Arg.is_req a && args = [] with + | true -> a :: misses + | false -> misses + in + loop misses cl max_spec al + in + let misses, cl, max_spec = loop [] cl (-1) posidx in + if misses <> [] then Error (Cmdliner_msg.err_pos_misses misses, cl) else + if last <= max_spec then Ok cl else + let excess = take_range (max_spec + 1) last pargs in + Error (Cmdliner_msg.err_pos_excess excess, cl) + +let create ?(peek_opts = false) al args = + let optidx, posidx, cl = arg_info_indexes al in + match parse_opt_args ~peek_opts optidx cl args with + | Ok (cl, _) when peek_opts -> Ok cl + | Ok (cl, pargs) -> process_pos_args posidx cl pargs + | Error (errs, cl, _) -> Error (errs, cl) + +let deprecated_msgs cl = + let add i arg acc = match Cmdliner_info.Arg.deprecated i with + | None -> acc + | Some msg -> + let plural l = if List.length l > 1 then "s " else " " in + match arg with + | O [] | P [] -> acc (* Should not happen *) + | O os -> + let plural = plural os in + let names = List.map (fun (_, n, _) -> n) os in + let names = String.concat " " (List.map Cmdliner_base.quote names) in + let msg = "option" :: plural :: names :: ": " :: msg :: [] in + String.concat "" msg :: acc + | P args -> + let plural = plural args in + let args = String.concat " " (List.map Cmdliner_base.quote args) in + let msg = "argument" :: plural :: args :: ": " :: msg :: [] in + String.concat "" msg :: acc + in + Amap.fold add cl [] + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_cline.mli b/src/cmdliner_cline.mli new file mode 100644 index 0000000..5651bda --- /dev/null +++ b/src/cmdliner_cline.mli @@ -0,0 +1,36 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(** Command lines. *) + +type t + +val create : + ?peek_opts:bool -> Cmdliner_info.Arg.Set.t -> string list -> + (t, string * t) result + +val opt_arg : t -> Cmdliner_info.Arg.t -> (int * string * (string option)) list +val pos_arg : t -> Cmdliner_info.Arg.t -> string list +val actual_args : t -> Cmdliner_info.Arg.t -> string list +(** Actual command line arguments from the command line *) + +val is_opt : string -> bool +val deprecated_msgs : t -> string list + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_cmd.ml b/src/cmdliner_cmd.ml new file mode 100644 index 0000000..5a156f3 --- /dev/null +++ b/src/cmdliner_cmd.ml @@ -0,0 +1,46 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2022 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(* Commands *) + +(* Command info *) + +type info = Cmdliner_info.Cmd.t +let info = Cmdliner_info.Cmd.v + +type 'a t = +| Cmd of info * 'a Cmdliner_term.parser +| Group of info * ('a Cmdliner_term.parser option * 'a t list) + +let get_info = function Cmd (i, _) | Group (i, _) -> i +let children_infos = function +| Cmd _ -> [] | Group (_, (_, cs)) -> List.map get_info cs + +let v i (args, p) = Cmd (Cmdliner_info.Cmd.add_args i args, p) +let group ?default i cmds = + let args, parser = match default with + | None -> None, None | Some (args, p) -> Some args, Some p + in + let children = List.map get_info cmds in + let i = Cmdliner_info.Cmd.with_children i ~args ~children in + Group (i, (parser, cmds)) + +let name c = Cmdliner_info.Cmd.name (get_info c) + +(*--------------------------------------------------------------------------- + Copyright (c) 2022 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_cmd.mli b/src/cmdliner_cmd.mli new file mode 100644 index 0000000..54da153 --- /dev/null +++ b/src/cmdliner_cmd.mli @@ -0,0 +1,40 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2022 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(** Commands and their information. *) + +type info = Cmdliner_info.Cmd.t + +val info : + ?deprecated:string -> + ?man_xrefs:Cmdliner_manpage.xref list -> ?man:Cmdliner_manpage.block list -> + ?envs:Cmdliner_info.Env.info list -> ?exits:Cmdliner_info.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 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 get_info : 'a t -> info + +(*--------------------------------------------------------------------------- + Copyright (c) 2022 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_docgen.ml b/src/cmdliner_docgen.ml new file mode 100644 index 0000000..d452ae8 --- /dev/null +++ b/src/cmdliner_docgen.ml @@ -0,0 +1,407 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +let rev_compare n0 n1 = compare n1 n0 +let strf = Printf.sprintf + +let order_args a0 a1 = + match Cmdliner_info.Arg.is_opt a0, Cmdliner_info.Arg.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_info.Arg.opt_names a0) + (key @@ Cmdliner_info.Arg.opt_names a1) + | false, false -> (* positional by variable *) + compare + (String.lowercase_ascii @@ Cmdliner_info.Arg.docv a0) + (String.lowercase_ascii @@ Cmdliner_info.Arg.docv a1) + | true, false -> -1 (* positional first *) + | false, true -> 1 (* optional after *) + +let esc = Cmdliner_manpage.escape +let cmd_name t = esc @@ Cmdliner_info.Cmd.name t + +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 + +(* Doc string variables substitutions. *) + +let env_info_subst ~subst e = function +| "env" -> Some (strf "$(b,%s)" @@ esc (Cmdliner_info.Env.info_var e)) +| id -> subst id + +let exit_info_subst ~subst e = function +| "status" -> Some (strf "%d" (fst @@ Cmdliner_info.Exit.info_codes e)) +| "status_max" -> Some (strf "%d" (snd @@ Cmdliner_info.Exit.info_codes e)) +| id -> subst id + +let arg_info_subst ~subst a = function +| "docv" -> + Some (strf "$(i,%s)" @@ esc (Cmdliner_info.Arg.docv a)) +| "opt" when Cmdliner_info.Arg.is_opt a -> + Some (strf "$(b,%s)" @@ esc (Cmdliner_info.Arg.opt_name_sample a)) +| "env" as id -> + begin match Cmdliner_info.Arg.env a with + | Some e -> env_info_subst ~subst e id + | None -> subst id + end +| id -> subst id + +let cmd_info_subst ei = function +| "tname" -> Some (strf "$(b,%s)" @@ cmd_name (Cmdliner_info.Eval.cmd ei)) +| "mname" -> Some (strf "$(b,%s)" @@ cmd_name (Cmdliner_info.Eval.main ei)) +| _ -> None + +(* Command docs *) + +let invocation ?(sep = " ") ?(parents = []) cmd = + let names = List.rev_map Cmdliner_info.Cmd.name (cmd :: parents) in + esc @@ String.concat sep names + +let synopsis_pos_arg a = + let v = match Cmdliner_info.Arg.docv a with "" -> "ARG" | v -> v in + let v = strf "$(i,%s)" (esc v) in + let v = (if Cmdliner_info.Arg.is_req a then strf "%s" else strf "[%s]") v in + match Cmdliner_info.Arg.(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_info.Arg.docv a with "" -> "VAL" | v -> v in + match Cmdliner_info.Arg.opt_kind a with + | Cmdliner_info.Arg.Flag -> strf "$(b,%s)" (esc n) + | Cmdliner_info.Arg.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_info.Arg.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_info.Cmd.deprecated cmd with +| None -> "" | Some _ -> "(Deprecated) " + +let synopsis ?parents cmd = match Cmdliner_info.Cmd.children cmd with +| [] -> + let rev_cli_order (a0, _) (a1, _) = + Cmdliner_info.Arg.rev_pos_cli_order a0 a1 + in + let args = Cmdliner_info.Cmd.args cmd in + let oargs, pargs = Cmdliner_info.Arg.(Set.partition is_opt 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_info.Arg.docs a = Cmdliner_manpage.s_options && + not (List.exists drop_names (Cmdliner_info.Arg.opt_names a)) + in + let oargs = Cmdliner_info.Arg.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 = + strf "[%s]" (synopsis_opt_arg a (Cmdliner_info.Arg.opt_name_sample a)) + 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_info.Arg.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" + (deprecated cmd) (invocation ?parents cmd) oargs pargs +| _cmds -> + let subcmd = match Cmdliner_info.Cmd.has_args cmd with + | false -> "$(i,COMMAND)" | true -> "[$(i,COMMAND)]" + in + strf "%s$(b,%s) %s …" (deprecated cmd) (invocation ?parents cmd) subcmd + +let cmd_docs ei = match Cmdliner_info.(Cmd.children (Eval.cmd ei)) with +| [] -> [] +| cmds -> + let add_cmd acc cmd = + let syn = synopsis cmd in + (Cmdliner_info.Cmd.docs cmd, `I (syn, Cmdliner_info.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_info.Arg.is_pos a with + | true -> strf "$(i,%s)" (esc @@ Cmdliner_info.Arg.docv a) + | false -> + let names = List.sort compare (Cmdliner_info.Arg.opt_names a) in + String.concat ", " (List.rev_map (synopsis_opt_arg a) names) + in + match Cmdliner_info.Arg.deprecated a with + | None -> s | Some _ -> "(Deprecated) " ^ s + +let arg_to_man_item ~errs ~subst ~buf a = + let subst = arg_info_subst ~subst a in + let or_env ~value a = match Cmdliner_info.Arg.env a with + | None -> "" + | Some e -> + let value = if value then " or" else "absent " in + strf "%s $(b,%s) env" value (esc @@ Cmdliner_info.Env.info_var e) + in + let absent = match Cmdliner_info.Arg.absent a with + | Cmdliner_info.Arg.Err -> "required" + | Cmdliner_info.Arg.Doc "" -> strf "%s" (or_env ~value:false a) + | Cmdliner_info.Arg.Doc s -> + let s = Cmdliner_manpage.subst_vars ~errs ~subst buf s in + strf "absent=%s%s" s (or_env ~value:true a) + | Cmdliner_info.Arg.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_info.Arg.opt_kind a with + | Cmdliner_info.Arg.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 doc = Cmdliner_info.Arg.doc a in + let doc = Cmdliner_manpage.subst_vars ~errs ~subst buf doc in + (Cmdliner_info.Arg.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_info.Arg.docs a0) (Cmdliner_info.Arg.docs a1) in + if c <> 0 then c else + let c = + match Cmdliner_info.Arg.deprecated a0, Cmdliner_info.Arg.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_info.Arg.(is_pos a && (docv a = "" || doc a = "")) + then (a :: acc) else acc + in + let args = Cmdliner_info.Cmd.args @@ Cmdliner_info.Eval.cmd ei in + let args = Cmdliner_info.Arg.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 e = + let subst = exit_info_subst ~subst e in + let min, max = Cmdliner_info.Exit.info_codes e in + let doc = Cmdliner_info.Exit.info_doc e 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_info.Exit.info_docs e, item) :: acc + in + let exits = Cmdliner_info.Cmd.exits @@ Cmdliner_info.Eval.cmd ei in + let exits = List.sort Cmdliner_info.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_info.Env.Set.mem e seen then acc else + let seen = Cmdliner_info.Env.Set.add e seen in + let var = strf "$(b,%s)" @@ esc (Cmdliner_info.Env.info_var e) in + let var = match Cmdliner_info.Env.info_deprecated e with + | None -> var | Some _ -> "(Deprecated) " ^ var in + let doc = Cmdliner_info.Env.info_doc e in + let doc = Cmdliner_manpage.subst_vars ~errs ~subst buf doc in + let envs = (Cmdliner_info.Env.info_docs e, `I (var, doc)) :: envs in + seen, envs + in + let add_arg_env a acc = match Cmdliner_info.Arg.env a with + | None -> acc + | Some e -> add_env_item ~subst:(arg_info_subst ~subst a) acc e + in + let add_env acc e = add_env_item ~subst:(env_info_subst ~subst e) 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_info.Cmd.args @@ Cmdliner_info.Eval.cmd ei in + let tenvs = Cmdliner_info.Cmd.envs @@ Cmdliner_info.Eval.cmd ei in + let init = Cmdliner_info.Env.Set.empty, [] in + let acc = Cmdliner_info.Arg.Set.fold add_arg_env 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_info.Eval.main ei in + let to_xref = function + | `Main -> Cmdliner_info.Cmd.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_info.Cmd.children main in + let mname = Cmdliner_info.Cmd.name main in + let is_cmd cmd = Cmdliner_info.Cmd.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_info.Cmd.man_xrefs @@ Cmdliner_info.Eval.cmd ei in + let xrefs = match main == Cmdliner_info.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_info.Eval.cmd ei in + let parents = Cmdliner_info.Eval.parents ei in + let tname = (deprecated cmd) ^ invocation ~sep:"-" ~parents cmd in + let tdoc = Cmdliner_info.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_info.Eval.cmd ei in + let parents = Cmdliner_info.Eval.parents ei in + let synopsis = `P (synopsis ~parents 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 = cmd_info_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_info.Cmd.man @@ Cmdliner_info.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_info.Eval.main ei in + let exec = String.capitalize_ascii (Cmdliner_info.Cmd.name main) in + let cmd = Cmdliner_info.Eval.cmd ei in + let parents = Cmdliner_info.Eval.parents ei in + let name = String.uppercase_ascii (invocation ~sep:"-" ~parents cmd) in + let center_header = esc @@ strf "%s Manual" exec in + let left_footer = + let version = match Cmdliner_info.Cmd.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 ~errs fmt ppf ei = + Cmdliner_manpage.print + ~errs ~subst:(cmd_info_subst ei) fmt ppf (man ~errs ei) + +(* Plain synopsis for usage *) + +let pp_plain_synopsis ~errs ppf ei = + let buf = Buffer.create 100 in + let subst = cmd_info_subst ei in + let cmd = Cmdliner_info.Eval.cmd ei in + let parents = Cmdliner_info.Eval.parents ei in + let synopsis = synopsis ~parents cmd in + let syn = Cmdliner_manpage.doc_to_plain ~errs ~subst buf synopsis in + Format.fprintf ppf "@[%s@]" syn + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_docgen.mli b/src/cmdliner_docgen.mli new file mode 100644 index 0000000..826bfac --- /dev/null +++ b/src/cmdliner_docgen.mli @@ -0,0 +1,27 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +val pp_man : + errs:Format.formatter -> Cmdliner_manpage.format -> Format.formatter -> + Cmdliner_info.Eval.t -> unit + +val pp_plain_synopsis : + errs:Format.formatter -> Format.formatter -> Cmdliner_info.Eval.t -> unit + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_eval.ml b/src/cmdliner_eval.ml new file mode 100644 index 0000000..c3747bf --- /dev/null +++ b/src/cmdliner_eval.ml @@ -0,0 +1,292 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2022 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +type 'a eval_ok = [ `Ok of 'a | `Version | `Help ] +type eval_error = [ `Parse | `Term | `Exn ] + +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 ei = + let docs = Cmdliner_info.Cmd.stdopts_docs @@ Cmdliner_info.Eval.cmd ei in + let vargs, vers = + match Cmdliner_info.Cmd.version @@ Cmdliner_info.Eval.main ei with + | None -> Cmdliner_info.Arg.Set.empty, None + | Some _ -> + let args, _ as vers = Cmdliner_arg.stdopt_version ~docs in + args, Some vers + in + let help = Cmdliner_arg.stdopt_help ~docs in + let args = Cmdliner_info.Arg.Set.union vargs (fst help) in + let cmd = Cmdliner_info.Cmd.add_args (Cmdliner_info.Eval.cmd ei) args in + help, vers, Cmdliner_info.Eval.with_cmd ei cmd + +let parse_error_term err ei cl = Error (`Parse err) + +type 'a eval_result = + ('a, [ Cmdliner_term.term_escape + | `Exn of exn * Printexc.raw_backtrace + | `Parse of string + | `Std_help of Cmdliner_manpage.format | `Std_version ]) result + +let run_parser ~catch ei cl f = try (f ei cl :> 'a eval_result) with +| exn when catch -> + let bt = Printexc.get_raw_backtrace () in + Error (`Exn (exn, bt)) + +let try_eval_stdopts ~catch ei cl help version = + match run_parser ~catch ei cl (snd help) with + | Ok (Some fmt) -> Some (Error (`Std_help fmt)) + | Error _ as err -> Some err + | Ok None -> + match version with + | None -> None + | Some version -> + match run_parser ~catch ei cl (snd version) with + | Ok false -> None + | Ok true -> Some (Error (`Std_version)) + | Error _ as err -> Some err + +let do_help help_ppf err_ppf ei fmt cmd = + let ei = match cmd with + | None (* help of main command requested *) -> + let env _ = assert false in + let cmd = Cmdliner_info.Eval.main ei in + let ei' = Cmdliner_info.Eval.v ~cmd ~parents:[] ~env ~err_ppf in + begin match Cmdliner_info.Eval.parents ei with + | [] -> (* [ei] is an evaluation of main, [cmd] has stdopts *) ei' + | _ -> let _, _, ei = add_stdopts ei' in ei + end + | Some cmd -> + try + (* For now we simply keep backward compat. [cmd] should be + a name from main's children. *) + let main = Cmdliner_info.Eval.main ei in + let is_cmd t = Cmdliner_info.Cmd.name t = cmd in + let children = Cmdliner_info.Cmd.children main in + let cmd = List.find is_cmd children in + let _, _, ei = add_stdopts (Cmdliner_info.Eval.with_cmd ei cmd) in + ei + with Not_found -> invalid_arg (err_help cmd) + in + Cmdliner_docgen.pp_man ~errs:err_ppf fmt help_ppf ei + +let do_result help_ppf err_ppf ei = function +| Ok v -> Ok (`Ok v) +| Error res -> + match res with + | `Std_help fmt -> + Cmdliner_docgen.pp_man ~errs:err_ppf fmt help_ppf ei; Ok `Help + | `Std_version -> + Cmdliner_msg.pp_version help_ppf ei; Ok `Version + | `Parse err -> + Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err; + Error `Parse + | `Help (fmt, cmd) -> do_help help_ppf err_ppf ei fmt cmd; Ok `Help + | `Exn (e, bt) -> Cmdliner_msg.pp_backtrace err_ppf ei e bt; (Error `Exn) + | `Error (usage, err) -> + (if usage + then Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:true ~err + else Cmdliner_msg.pp_err err_ppf ei ~err); + (Error `Term) + +let cmd_name_trie cmds = + let add acc cmd = + let i = Cmdliner_cmd.get_info cmd in + let name = Cmdliner_info.Cmd.name i in + match Cmdliner_trie.add acc name cmd with + | `New t -> t + | `Replaced (cmd', _) -> + let i' = Cmdliner_cmd.get_info cmd' and kind = "command" in + invalid_arg @@ + Cmdliner_base.err_multi_def ~kind name Cmdliner_info.Cmd.doc i i' + in + List.fold_left add Cmdliner_trie.empty cmds + +let cmd_name_dom cmds = + let cmd_name c = Cmdliner_info.Cmd.name (Cmdliner_cmd.get_info c) in + List.sort String.compare (List.rev_map cmd_name cmds) + +let find_term args cmd = + let never_term _ _ = assert false in + let stop args_rest args_rev parents cmd = + let args = List.rev_append args_rev args_rest in + match (cmd : 'a Cmdliner_cmd.t) with + | Cmd (i, t) -> + args, t, i, parents, Ok () + | Group (i, (Some t, children)) -> + args, t, i, parents, Ok () + | Group (i, (None, children)) -> + let dom = cmd_name_dom children in + let err = Cmdliner_msg.err_cmd_missing ~dom in + args, never_term, i, parents, Error err + in + let rec loop args_rev parents cmd = function + | ("--" :: _ | [] as rest) -> stop rest args_rev parents cmd + | (arg :: _ as rest) when Cmdliner_cline.is_opt arg -> + stop rest args_rev parents cmd + | arg :: args -> + match cmd with + | Cmd (i, t) -> + let args = List.rev_append args_rev (arg :: args) in + args, t, i, parents, Ok () + | Group (i, (t, children)) -> + let index = cmd_name_trie children in + match Cmdliner_trie.find index arg with + | `Ok cmd -> loop args_rev (i :: parents) cmd args + | `Not_found -> + let args = List.rev_append args_rev (arg :: args) in + let all = Cmdliner_trie.ambiguities index "" in + let hints = Cmdliner_base.suggest arg all in + let dom = cmd_name_dom children in + let kind = "command" in + let err = Cmdliner_base.err_unknown ~kind ~dom ~hints arg in + args, never_term, i, parents, Error err + | `Ambiguous -> + let args = List.rev_append args_rev (arg :: args) in + let ambs = Cmdliner_trie.ambiguities index arg in + let ambs = List.sort compare ambs in + let err = Cmdliner_base.err_ambiguous ~kind:"command" arg ~ambs in + args, never_term, i, parents, Error err + in + loop [] [] cmd args + +let env_default v = try Some (Sys.getenv v) with Not_found -> None +let remove_exec argv = + try List.tl (Array.to_list argv) with Failure _ -> invalid_arg err_argv + +let do_deprecated_msgs err_ppf cl ei = + let cmd = Cmdliner_info.Eval.cmd ei in + let msgs = Cmdliner_cline.deprecated_msgs cl in + let msgs = match Cmdliner_info.Cmd.deprecated cmd with + | None -> msgs + | Some msg -> + let name = Cmdliner_base.quote (Cmdliner_info.Cmd.name cmd) in + String.concat "" ("command " :: name :: ": " :: msg :: []) :: msgs + in + if msgs <> [] + then Cmdliner_msg.pp_err err_ppf ei ~err:(String.concat "\n" msgs) + +let eval_value + ?help:(help_ppf = Format.std_formatter) + ?err:(err_ppf = Format.err_formatter) + ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) cmd + = + let args, f, cmd, parents, res = find_term (remove_exec argv) cmd in + let ei = Cmdliner_info.Eval.v ~cmd ~parents ~env ~err_ppf in + let help, version, ei = add_stdopts ei in + let term_args = Cmdliner_info.Cmd.args @@ Cmdliner_info.Eval.cmd ei in + let res = match res with + | Error msg -> (* Command lookup error, we still prioritize stdargs *) + let cl = match Cmdliner_cline.create term_args args with + | Error (_, cl) -> cl | Ok cl -> cl + in + begin match try_eval_stdopts ~catch ei cl help version with + | Some e -> e + | None -> Error (`Error (true, msg)) + end + | Ok () -> + match Cmdliner_cline.create term_args args with + | Error (e, cl) -> + begin match try_eval_stdopts ~catch ei cl help version with + | Some e -> e + | None -> Error (`Error (true, e)) + end + | Ok cl -> + match try_eval_stdopts ~catch ei cl help version with + | Some e -> e + | None -> + do_deprecated_msgs err_ppf cl ei; + run_parser ~catch ei cl f + in + do_result help_ppf err_ppf ei res + +let eval_peek_opts + ?(version_opt = false) ?(env = env_default) ?(argv = Sys.argv) t + : 'a option * ('a eval_ok, eval_error) result + = + let args, f = t in + let version = if version_opt then Some "dummy" else None in + let cmd = Cmdliner_info.Cmd.v ?version "dummy" in + let cmd = Cmdliner_info.Cmd.add_args cmd args in + let null_ppf = Format.make_formatter (fun _ _ _ -> ()) (fun () -> ()) in + let ei = Cmdliner_info.Eval.v ~cmd ~parents:[] ~env ~err_ppf:null_ppf in + let help, version, ei = add_stdopts ei in + let term_args = Cmdliner_info.Cmd.args @@ Cmdliner_info.Eval.cmd ei in + let cli_args = remove_exec argv in + let v, ret = + match Cmdliner_cline.create ~peek_opts:true term_args cli_args with + | Error (e, cl) -> + begin match try_eval_stdopts ~catch:true ei cl help version with + | Some e -> None, e + | None -> None, Error (`Error (true, e)) + end + | Ok cl -> + let ret = run_parser ~catch:true ei cl f in + let v = match ret with Ok v -> Some v | Error _ -> None in + match try_eval_stdopts ~catch:true ei cl help version with + | Some e -> v, e + | None -> v, ret + 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 `Exn _ -> Error `Exn + | Error `Error _ -> Error `Term + in + (v, ret) + +let exit_status_of_result ?(term_err = Cmdliner_info.Exit.cli_error) = function +| Ok (`Ok _ | `Help | `Version) -> Cmdliner_info.Exit.ok +| Error `Term -> term_err +| Error `Parse -> Cmdliner_info.Exit.cli_error +| Error `Exn -> Cmdliner_info.Exit.internal_error + +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 = (* FIXME move that to Cmdliner_msgs *) + let name = Cmdliner_cmd.name cmd in + Format.fprintf ppf "%s: @[%a@]@." name Cmdliner_base.pp_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_info.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_info.Exit.some_error + | r -> exit_status_of_result ?term_err r + +(*--------------------------------------------------------------------------- + Copyright (c) 2022 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_eval.mli b/src/cmdliner_eval.mli new file mode 100644 index 0000000..18746d9 --- /dev/null +++ b/src/cmdliner_eval.mli @@ -0,0 +1,60 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2022 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(** Command evaluation *) + +(** {1:eval Evaluating commands} *) + +type 'a eval_ok = [ `Ok of 'a | `Version | `Help ] +type eval_error = [ `Parse | `Term | `Exn ] + +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_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_info.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_info.Exit.code + +val eval_result : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:Cmdliner_info.Exit.code -> (unit, string) result Cmdliner_cmd.t -> + Cmdliner_info.Exit.code + +val eval_result' : + ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool -> + ?env:(string -> string option) -> ?argv:string array -> + ?term_err:Cmdliner_info.Exit.code -> + (Cmdliner_info.Exit.code, string) result Cmdliner_cmd.t -> + Cmdliner_info.Exit.code + +(*--------------------------------------------------------------------------- + Copyright (c) 2022 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_exit.ml b/src/cmdliner_exit.ml new file mode 100644 index 0000000..5a9fe79 --- /dev/null +++ b/src/cmdliner_exit.ml @@ -0,0 +1,21 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_exit.mli b/src/cmdliner_exit.mli new file mode 100644 index 0000000..5a9fe79 --- /dev/null +++ b/src/cmdliner_exit.mli @@ -0,0 +1,21 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_info.ml b/src/cmdliner_info.ml new file mode 100644 index 0000000..d516fc1 --- /dev/null +++ b/src/cmdliner_info.ml @@ -0,0 +1,241 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(* 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)."; ] +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 + + module Set = Set.Make (struct type t = info let compare = info_compare end) +end + +(* Arguments *) + +module Arg = 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 + + 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. *) + 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 dumb_pos = pos ~rev:false ~start:(-1) ~len:None + + let v ?deprecated ?(absent = "") ?docs ?(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; docs; pos = dumb_pos; opt_kind = Flag; opt_names; + opt_all = false; } + + let id a = a.id + let deprecated a = a.deprecated + let absent a = a.absent + let env a = a.env + let doc a = a.doc + let docv a = a.docv + let docs a = a.docs + let pos_kind a = a.pos + let opt_kind a = a.opt_kind + let opt_names a = a.opt_names + let opt_all a = a.opt_all + let opt_name_sample a = + (* 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 a.opt_names + | n :: ns -> if (String.length n) > 2 then n else find ns + in + find a.opt_names + + let make_req a = { a with absent = Err } + let make_all_opts a = { a with opt_all = true } + let make_opt ~absent ~kind:opt_kind a = { a with absent; opt_kind } + let make_opt_all ~absent ~kind:opt_kind a = + { a with absent; opt_kind; opt_all = true } + + let make_pos ~pos a = { a with pos } + let make_pos_abs ~absent ~pos a = { a with absent; pos } + + let is_opt a = a.opt_names <> [] + let is_pos a = a.opt_names = [] + let is_req a = a.absent = Err + + let pos_cli_order a0 a1 = (* best-effort order on the cli. *) + let c = compare (a0.pos.pos_rev) (a1.pos.pos_rev) in + if c <> 0 then c else + if a0.pos.pos_rev + then compare a1.pos.pos_start a0.pos.pos_start + else compare a0.pos.pos_start a1.pos.pos_start + + let rev_pos_cli_order a0 a1 = pos_cli_order a1 a0 + + let compare a0 a1 = Int.compare a0.id a1.id + module Set = Set.Make (struct type nonrec t = t let compare = compare end) +end + +(* Commands *) + +module Cmd = struct + type t = + { 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.t; (* Command arguments. *) + has_args : bool; (* [true] if has own parsing term. *) + children : t list; } (* Children, if any. *) + + let v + ?deprecated ?(man_xrefs = [`Main]) ?(man = []) ?(envs = []) + ?(exits = Exit.defaults) ?(sdocs = Cmdliner_manpage.s_common_options) + ?(docs = Cmdliner_manpage.s_commands) ?(doc = "") ?version name + = + { name; version; deprecated; doc; docs; sdocs; exits; + envs; man; man_xrefs; args = Arg.Set.empty; + has_args = true; children = [] } + + let name t = t.name + let version t = t.version + let deprecated t = t.deprecated + let doc t = t.doc + let docs t = t.docs + let stdopts_docs t = t.sdocs + let exits t = t.exits + let envs t = t.envs + let man t = t.man + let man_xrefs t = t.man_xrefs + let args t = t.args + let has_args t = t.has_args + let children t = t.children + let add_args t args = { t with args = Arg.Set.union args t.args } + let with_children cmd ~args ~children = + let has_args, args = match args with + | None -> false, cmd.args + | Some args -> true, Arg.Set.union args cmd.args + in + { cmd with has_args; args; children } +end + +(* Evaluation *) + +module Eval = struct + type t = (* information about the evaluation context. *) + { cmd : Cmd.t; (* cmd being evaluated. *) + parents : Cmd.t list; (* parents of cmd, root is last. *) + env : string -> string option; (* environment variable lookup. *) + err_ppf : Format.formatter (* error formatter *) } + + let v ~cmd ~parents ~env ~err_ppf = { cmd; parents; env; err_ppf } + + let cmd e = e.cmd + let parents e = e.parents + let env_var e v = e.env v + let err_ppf e = e.err_ppf + let main e = match List.rev e.parents with [] -> e.cmd | m :: _ -> m + let with_cmd ei cmd = { ei with cmd } +end + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_info.mli b/src/cmdliner_info.mli new file mode 100644 index 0000000..d82b03c --- /dev/null +++ b/src/cmdliner_info.mli @@ -0,0 +1,155 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(** Exit codes, environment variabes, arguments, commands and eval information. + + These information types gathers untyped data used to parse command + lines report errors and format man pages. *) + +(** 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 +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 + + module Set : Set.S with type elt = info +end + +(** Arguments *) +module Arg : 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 v : + ?deprecated:string -> ?absent:string -> ?docs:string -> ?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 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 : absent:absence -> kind:opt_kind -> t -> t + val make_opt_all : absent:absence -> kind:opt_kind -> t -> t + val make_pos : pos:pos_kind -> t -> t + val make_pos_abs : 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 + module Set : Set.S with type elt = t +end + +(** Commands. *) +module Cmd : sig + type t + val v : + ?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.Set.t + val has_args : t -> bool + val children : t -> t list + val add_args : t -> Arg.Set.t -> t + val with_children : t -> args:Arg.Set.t option -> children:t list -> t +end + +(** Evaluation. *) +module Eval : sig + type t + val v : + cmd:Cmd.t -> parents:Cmd.t list -> env:(string -> string option) -> + err_ppf:Format.formatter -> t + + val cmd : t -> Cmd.t + val main : t -> Cmd.t + val parents : t -> Cmd.t list + val env_var : t -> string -> string option + val err_ppf : t -> Format.formatter + val with_cmd : t -> Cmd.t -> t +end + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_manpage.ml b/src/cmdliner_manpage.ml new file mode 100644 index 0000000..46353d5 --- /dev/null +++ b/src/cmdliner_manpage.ml @@ -0,0 +1,513 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(* Manpages *) + +type block = + [ `S of string | `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 "$(tname) exits with the following status:" + +let s_environment = "ENVIRONMENT" +let s_environment_intro = + `P "These environment variables affect the execution of $(tname):" + +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 +let pf = Format.fprintf +let pp_str = Format.pp_print_string +let pp_char = Format.pp_print_char +let pp_indent ppf c = for i = 1 to c do pp_char ppf ' ' done +let pp_lines = Cmdliner_base.pp_lines +let pp_tokens = Cmdliner_base.pp_tokens + +(* Cmdliner markup handling *) + +let err e 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 ~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 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 + if not (is_markup_dir markup) + then (err_markup ~errs markup s; loop start next) else + let start_data = min + 1 in + (flush start (i - 1); + add_markup_text ~errs loop b s start_data need_escape escape) + | _ -> + 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 ~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 = pp_tokens ~spaces:true ppf t in + let rec loop = function + | [] -> () + | t :: ts -> + begin match t with + | `Noblank -> () + | `Blocks bs -> loop bs (* not T.R. *) + | `P s -> pf ppf "%a@[%a@]@," pp_indent p_indent pp_tokens (markup s) + | `S s -> pf ppf "@[%a@]" pp_tokens (markup s) + | `Pre s -> pf ppf "%a@[%a@]@," pp_indent p_indent pp_lines (markup s) + | `I (label, s) -> + let label = markup label in + let s = markup s in + pf ppf "@[%a@[%a@]" pp_indent p_indent pp_tokens label; + if s = "" then pf ppf "@]@," else + let ll = String.length label in + begin match ll < l_indent with + | true -> + pf ppf "%a@[%a@]@]" pp_indent (l_indent - ll) pp_tokens s + | false -> + pf ppf "@\n%a@[%a@]@]" + pp_indent (p_indent + l_indent) pp_tokens s + end; + match ts with `I _ :: _ -> pf ppf "@," | _ -> () + end; + begin match ts with + | `Noblank :: ts -> loop ts + | ts -> Format.pp_print_cut ppf (); loop ts + end + in + loop ts + +let pp_plain_page ~errs subst ppf (_, text) = + pf ppf "@[%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 = pp_tokens ~spaces:false ppf t in + let rec pp_block = function + | `Blocks bs -> List.iter pp_block bs (* not T.R. *) + | `P s -> pf ppf "@\n.P@\n%a" pp_tokens (markup s) + | `Pre s -> pf ppf "@\n.P@\n.nf@\n%a@\n.fi" pp_lines (markup s) + | `S s -> pf ppf "@\n.SH %a" pp_tokens (markup s) + | `Noblank -> pf ppf "@\n.sp -1" + | `I (l, s) -> + 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) = + 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 find_cmd cmds = + let test, null = match Sys.os_type with + | "Win32" -> "where", " NUL" + | _ -> "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 pp_to_pager print ppf v = + let pager = + let cmds = ["less"," -R"; "more", ""] in + (* Fundamentally env var lookups should try to cut the exec name. *) + let cmds = try (Sys.getenv "PAGER", "") :: cmds with Not_found -> cmds in + let cmds = try (Sys.getenv "MANPAGER", "") :: cmds with Not_found -> cmds in + find_cmd cmds + in + match pager with + | None -> print `Plain ppf v + | Some (pager, opts) -> + let pager = 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 -> 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 format = [ `Auto | `Pager | `Plain | `Groff ] + +let rec print + ?(errs = Format.err_formatter) + ?(subst = fun x -> None) fmt ppf page = + match fmt with + | `Pager -> pp_to_pager (print ~errs ~subst) ppf page + | `Plain -> pp_plain_page ~errs subst ppf page + | `Groff -> pp_groff_page ~errs subst ppf page + | `Auto -> + match try (Some (Sys.getenv "TERM")) with Not_found -> None with + | None | Some "dumb" -> print ~errs ~subst `Plain ppf page + | Some _ -> print ~errs ~subst `Pager ppf page + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_manpage.mli b/src/cmdliner_manpage.mli new file mode 100644 index 0000000..5d43a5b --- /dev/null +++ b/src/cmdliner_manpage.mli @@ -0,0 +1,100 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(** Manpages. + + See {!Cmdliner.Manpage}. *) + +type block = + [ `S of string | `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 : string +val s_synopsis : string +val s_description : string +val s_commands : string +val s_arguments : string +val s_options : string +val s_common_options : string +val s_exit_status : string +val s_environment : string +val s_files : string +val s_bugs : string +val s_examples : string +val s_authors : string +val s_see_also : string +val s_none : string + +(** {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:string -> bool +val smap_append_block : smap -> sec:string -> 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 format = [ `Auto | `Pager | `Plain | `Groff ] +val print : + ?errs:Format.formatter -> ?subst:(string -> string option) -> format -> + Format.formatter -> t -> unit + +(** {1 Printers and escapes used by Cmdliner module} *) + +val subst_vars : + errs:Format.formatter -> subst:(string -> string option) -> 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:(string -> string option) -> Buffer.t -> + string -> string +(** [doc_to_plain b ~subst s] using [b], subsitutes in [s] variables by + their [subst] definition and renders cmdliner directives to plain + text. + + @raise Invalid_argument in case of illegal syntax. *) + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_msg.ml b/src/cmdliner_msg.ml new file mode 100644 index 0000000..a61c815 --- /dev/null +++ b/src/cmdliner_msg.ml @@ -0,0 +1,122 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +let strf = Printf.sprintf +let quote = Cmdliner_base.quote + +let pp = Format.fprintf +let pp_text = Cmdliner_base.pp_text +let pp_lines = Cmdliner_base.pp_lines + +(* Environment variable errors *) + +let err_env_parse env ~err = + let var = Cmdliner_info.Env.info_var env in + strf "environment variable %s: %s" (quote var) err + +(* Positional argument errors *) + +let err_pos_excess excess = + strf "too many arguments, don't know what to do with %s" + (String.concat ", " (List.map quote excess)) + +let err_pos_miss a = match Cmdliner_info.Arg.docv a with +| "" -> "a required argument is missing" +| v -> strf "required argument %s is missing" v + +let err_pos_misses = function +| [] -> assert false +| [a] -> err_pos_miss a +| args -> + let add_arg acc a = match Cmdliner_info.Arg.docv a with + | "" -> "ARG" :: acc + | argv -> argv :: acc + in + let rev_args = List.sort Cmdliner_info.Arg.rev_pos_cli_order args in + let args = List.fold_left add_arg [] rev_args in + let args = String.concat ", " args in + strf "required arguments %s are missing" args + +let err_pos_parse a ~err = match Cmdliner_info.Arg.docv a with +| "" -> err +| argv -> + match Cmdliner_info.Arg.(pos_len @@ pos_kind a) with + | Some 1 -> strf "%s argument: %s" argv err + | None | Some _ -> strf "%s… arguments: %s" argv err + +(* Optional argument errors *) + +let err_flag_value flag v = + strf "option %s is a flag, it cannot take the argument %s" + (quote flag) (quote v) + +let err_opt_value_missing f = strf "option %s needs an argument" (quote f) +let err_opt_parse f ~err = strf "option %s: %s" (quote f) err +let err_opt_repeated f f' = + if f = f' then strf "option %s cannot be repeated" (quote f) else + strf "options %s and %s cannot be present at the same time" + (quote f) (quote f') + +(* Argument errors *) + +let err_arg_missing a = + if Cmdliner_info.Arg.is_pos a then err_pos_miss a else + strf "required option %s is missing" (Cmdliner_info.Arg.opt_name_sample a) + +let err_cmd_missing ~dom = + strf "required COMMAND name is missing, must be %s." + (Cmdliner_base.alts_str ~quoted:true dom) + +(* Other messages *) + +let exec_name ei = Cmdliner_info.Cmd.name @@ Cmdliner_info.Eval.main ei + +let pp_version ppf ei = + match Cmdliner_info.Cmd.version @@ Cmdliner_info.Eval.main ei with + | None -> assert false + | Some v -> pp ppf "@[%a@]@." Cmdliner_base.pp_text v + +let pp_try_help ppf ei = + let rcmds = Cmdliner_info.Eval.(cmd ei :: parents ei) in + match List.rev_map Cmdliner_info.Cmd.name rcmds with + | [] -> assert false + | [n] -> pp ppf "@[<2>Try '%s --help' for more information.@]" n + | n :: _ as cmds -> + let cmds = String.concat " " cmds in + pp ppf "@[<2>Try '%s --help' or '%s --help' for more information.@]" + cmds n + +let pp_err ppf ei ~err = pp ppf "%s: @[%a@]@." (exec_name ei) pp_lines err + +let pp_err_usage ppf ei ~err_lines ~err = + let pp_err = if err_lines then pp_lines else pp_text in + pp ppf "@[%s: @[%a@]@,@[Usage: @[%a@]@]@,%a@]@." + (exec_name ei) pp_err err (Cmdliner_docgen.pp_plain_synopsis ~errs:ppf) ei + pp_try_help ei + +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 + pp ppf "%s: @[internal error, uncaught exception:@\n%a@]@." + (exec_name ei) pp_lines (strf "%s\n%s" (Printexc.to_string e) bt) + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_msg.mli b/src/cmdliner_msg.mli new file mode 100644 index 0000000..125e175 --- /dev/null +++ b/src/cmdliner_msg.mli @@ -0,0 +1,56 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(** Messages for the end-user. *) + +(** {1:env_err Environment variable errors} *) + +val err_env_parse : Cmdliner_info.Env.info -> err:string -> string + +(** {1:pos_err Positional argument errors} *) + +val err_pos_excess : string list -> string +val err_pos_misses : Cmdliner_info.Arg.t list -> string +val err_pos_parse : Cmdliner_info.Arg.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_info.Arg.t -> string +val err_cmd_missing : dom:string list -> string + +(** {1:msgs Other messages} *) + +val pp_version : Format.formatter -> Cmdliner_info.Eval.t -> unit +val pp_try_help : Format.formatter -> Cmdliner_info.Eval.t -> unit +val pp_err : Format.formatter -> Cmdliner_info.Eval.t -> err:string -> unit +val pp_err_usage : + Format.formatter -> Cmdliner_info.Eval.t -> err_lines:bool -> err:string -> unit + +val pp_backtrace : + Format.formatter -> + Cmdliner_info.Eval.t -> exn -> Printexc.raw_backtrace -> unit + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_term.ml b/src/cmdliner_term.ml new file mode 100644 index 0000000..13220cf --- /dev/null +++ b/src/cmdliner_term.ml @@ -0,0 +1,98 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +type term_escape = + [ `Error of bool * string + | `Help of Cmdliner_manpage.format * string option ] + +type 'a parser = + Cmdliner_info.Eval.t -> Cmdliner_cline.t -> + ('a, [ `Parse of string | term_escape ]) result + +type 'a t = Cmdliner_info.Arg.Set.t * 'a parser + +let const v = Cmdliner_info.Arg.Set.empty, (fun _ _ -> Ok v) +let app (args_f, f) (args_v, v) = + Cmdliner_info.Arg.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) + +(* 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_info.Arg.Set.empty, + (fun ei _ -> Ok (Cmdliner_info.Cmd.name @@ Cmdliner_info.Eval.main ei)) + +let choice_names = + Cmdliner_info.Arg.Set.empty, + (fun ei _ -> + (* N.B. this keeps everything backward compatible. We return the command + names of main's children *) + let name t = Cmdliner_info.Cmd.name t in + let choices = Cmdliner_info.Cmd.children (Cmdliner_info.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_cline.actual_args cl arg_info in + List.rev_append args acc + in + let used = List.rev (Cmdliner_info.Arg.Set.fold actual_args al []) in + Ok (x, used) + | Error _ as e -> e + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_term.mli b/src/cmdliner_term.mli new file mode 100644 index 0000000..c9b280e --- /dev/null +++ b/src/cmdliner_term.mli @@ -0,0 +1,51 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(** Terms *) + +type term_escape = + [ `Error of bool * string + | `Help of Cmdliner_manpage.format * string option ] + +type 'a parser = + Cmdliner_info.Eval.t -> Cmdliner_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 = Cmdliner_info.Arg.Set.t * 'a parser +(** The type for terms. The list of arguments it can parse and the parsing + function that does so. *) + +val const : 'a -> 'a t +val app : ('a -> 'b) t -> 'a t -> 'b t +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 + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_term_deprecated.ml b/src/cmdliner_term_deprecated.ml new file mode 100644 index 0000000..a156d3b --- /dev/null +++ b/src/cmdliner_term_deprecated.ml @@ -0,0 +1,93 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(* Term combinators *) + +let man_format = Cmdliner_arg.man_format +let pure = Cmdliner_term.const + +(* Term information *) + +type exit_info = Cmdliner_info.Exit.info +let exit_info = Cmdliner_info.Exit.info + +let exit_status_success = Cmdliner_info.Exit.ok +let exit_status_cli_error = Cmdliner_info.Exit.cli_error +let exit_status_internal_error = Cmdliner_info.Exit.internal_error +let default_error_exits = + [ exit_info exit_status_cli_error ~doc:"on command line parsing errors."; + exit_info exit_status_internal_error + ~doc:"on unexpected internal errors (bugs)."; ] + +let default_exits = + (exit_info exit_status_success ~doc:"on success.") :: default_error_exits + +type env_info = Cmdliner_info.Env.info +let env_info = Cmdliner_info.Env.info ?deprecated:None + +type info = Cmdliner_info.Cmd.t +let info + ?(man_xrefs = []) ?man ?envs ?(exits = []) + ?(sdocs = Cmdliner_manpage.s_options) ?docs ?doc ?version name + = + Cmdliner_info.Cmd.v + ~man_xrefs ?man ?envs ~exits ~sdocs ?docs ?doc ?version name + +let name ti = Cmdliner_info.Cmd.name ti + +(* Evaluation *) + +type 'a result = +[ `Ok of 'a | `Error of [`Parse | `Term | `Exn ] | `Version | `Help ] + +let to_legacy_result = function +| Ok (#Cmdliner_eval.eval_ok as r) -> (r : 'a result) +| Error e -> `Error e + +let eval ?help ?err ?catch ?env ?argv (t, i) = + let cmd = Cmdliner_cmd.v i t in + to_legacy_result (Cmdliner_eval.eval_value ?help ?err ?catch ?env ?argv cmd) + +let eval_choice ?help ?err ?catch ?env ?argv (t, i) choices = + let sub (t, i) = Cmdliner_cmd.v i t in + let cmd = Cmdliner_cmd.group i ~default:t (List.map sub choices) in + to_legacy_result (Cmdliner_eval.eval_value ?help ?err ?catch ?env ?argv cmd) + +let eval_peek_opts ?version_opt ?env ?argv t = + let o, r = Cmdliner_eval.eval_peek_opts ?version_opt ?env ?argv t in + o, to_legacy_result r + +(* Exits *) + +let exit_status_of_result ?(term_err = 1) = function +| `Ok () | `Help | `Version -> exit_status_success +| `Error `Term -> term_err +| `Error `Exn -> exit_status_internal_error +| `Error `Parse -> exit_status_cli_error + +let exit_status_of_status_result ?term_err = function +| `Ok n -> n +| `Help | `Version | `Error _ as r -> exit_status_of_result ?term_err r + +let stdlib_exit = exit +let exit ?term_err r = stdlib_exit (exit_status_of_result ?term_err r) +let exit_status ?term_err r = + stdlib_exit (exit_status_of_status_result ?term_err r) + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_trie.ml b/src/cmdliner_trie.ml new file mode 100644 index 0000000..e7e6a7a --- /dev/null +++ b/src/cmdliner_trie.ml @@ -0,0 +1,96 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +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 t k = + try match (find_node t k).v with + | Key v | Pre v -> `Ok v | Amb -> `Ambiguous | Nil -> `Not_found + with Not_found -> `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 + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/cmdliner_trie.mli b/src/cmdliner_trie.mli new file mode 100644 index 0000000..4b77a7f --- /dev/null +++ b/src/cmdliner_trie.mli @@ -0,0 +1,34 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 The cmdliner programmers. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + ---------------------------------------------------------------------------*) + +(** 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 : 'a t -> string -> [ `Ok of 'a | `Ambiguous | `Not_found ] +val ambiguities : 'a t -> string -> string list +val of_list : (string * 'a) list -> 'a t + +(*--------------------------------------------------------------------------- + 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. + ---------------------------------------------------------------------------*) diff --git a/src/dune b/src/dune new file mode 100644 index 0000000..b9ef5c9 --- /dev/null +++ b/src/dune @@ -0,0 +1,4 @@ +(library + (public_name cmdliner) + (flags :standard -w -3-6-27-32-35) + (wrapped false)) diff --git a/test/chorus.ml b/test/chorus.ml new file mode 100644 index 0000000..ee113cf --- /dev/null +++ b/test/chorus.ml @@ -0,0 +1,35 @@ +(* Example from the documentation, this code is in public domain. *) + +(* Implementation of the command *) + +let chorus count msg = for i = 1 to count do print_endline msg done + +(* Command line interface *) + +open Cmdliner + +let count = + let doc = "Repeat the message $(docv) times." in + Arg.(value & opt int 10 & info ["c"; "count"] ~docv:"COUNT" ~doc) + +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 ~docv:"MSG" ~doc) + +let chorus_t = Term.(const chorus $ count $ msg) + +let cmd = + let doc = "Print a customizable message repeatedly" in + let man = [ + `S Manpage.s_bugs; + `P "Email bug reports to ." ] + in + let info = Cmd.info "chorus" ~version:"v1.1.1" ~doc ~man in + Cmd.v info chorus_t + +let main () = exit (Cmd.eval cmd) +let () = main () diff --git a/test/cp_ex.ml b/test/cp_ex.ml new file mode 100644 index 0000000..944037d --- /dev/null +++ b/test/cp_ex.ml @@ -0,0 +1,53 @@ +(* Example from the documentation, this code is in public domain. *) + +(* 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 + +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 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 ."; ] + in + let info = Cmd.info "cp" ~version:"v1.1.1" ~doc ~man ~man_xrefs in + Cmd.v info Term.(ret (const cp $ verbose $ recurse $ force $ srcs $ dest)) + + +let main () = exit (Cmd.eval cmd) +let () = main () diff --git a/test/darcs_ex.ml b/test/darcs_ex.ml new file mode 100644 index 0000000..8ebd2f6 --- /dev/null +++ b/test/darcs_ex.ml @@ -0,0 +1,148 @@ +(* Example from the documentation, this code is in public domain. *) + +(* 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 + match conv 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 + +(* 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 $(mname) $(i,COMMAND) --help for help on a single command.";`Noblank; + `P "Use $(mname) $(b,help patterns) for help on patch matching."; `Noblank; + `P "Use $(mname) $(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 $(mname) 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 + let info = Cmd.info "initialize" ~doc ~sdocs ~man in + Cmd.v info Term.(const 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 + let info = Cmd.info "record" ~doc ~sdocs ~man in + Cmd.v info + Term.(const 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 + let info = Cmd.info "help" ~doc ~man in + Cmd.v info + Term.(ret (const help $ copts_t $ Arg.man_format $ Term.choice_names $ + topic)) + +let main_cmd = + let doc = "a revision control system" in + let man = help_secs in + let info = Cmd.info "darcs" ~version:"v1.1.1" ~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 () = exit (Cmd.eval main_cmd) diff --git a/test/dune b/test/dune new file mode 100644 index 0000000..ba88438 --- /dev/null +++ b/test/dune @@ -0,0 +1,13 @@ +(executables + (names test_man + test_man_utf8 + test_pos + test_nest + test_pos_rev + test_pos_all + test_pos_left + test_pos_req + test_opt_req + test_term_dups + test_with_used_args) + (libraries cmdliner)) diff --git a/test/revolt.ml b/test/revolt.ml new file mode 100644 index 0000000..759bba2 --- /dev/null +++ b/test/revolt.ml @@ -0,0 +1,9 @@ +(* Example from the documentation, this code is in public domain. *) + +let revolt () = print_endline "Revolt!" + +open Cmdliner + +let revolt_t = Term.(const revolt $ const ()) +let cmd = Cmd.v (Cmd.info "revolt") revolt_t +let () = exit (Cmd.eval cmd) diff --git a/test/rm_ex.ml b/test/rm_ex.ml new file mode 100644 index 0000000..967d28f --- /dev/null +++ b/test/rm_ex.ml @@ -0,0 +1,60 @@ +(* Example from the documentation, this code is in public domain. *) + +(* 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 + +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 cmd = + let doc = "Remove files or directories" in + let man = [ + `S Manpage.s_description; + `P "$(tname) 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 "$(mname) $(b,-- -foo)"; `Noblank; + `Pre "$(mname) $(b,./-foo)"; + `P "$(tname) removes symbolic links, not the files referenced by the + links."; + `S Manpage.s_bugs; `P "Report bugs to ."; + `S Manpage.s_see_also; `P "$(b,rmdir)(1), $(b,unlink)(2)" ] + in + let info = Cmd.info "rm" ~version:"v1.1.1" ~doc ~man in + Cmd.v info Term.(const rm $ prompt $ recursive $ files) + +let main () = exit (Cmd.eval cmd) +let () = main () diff --git a/test/tail_ex.ml b/test/tail_ex.ml new file mode 100644 index 0000000..4a9a782 --- /dev/null +++ b/test/tail_ex.ml @@ -0,0 +1,85 @@ +(* Example from the documentation, this code is in public domain. *) + +(* 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 + +let loc_arg = + let parse 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 (`Msg "unable to parse integer") + in + let print ppf p = Format.fprintf ppf "%s" (loc_str p) in + Arg.conv ~docv:"N" (parse, print) + +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 cmd = + let doc = "Display the last part of a file" in + let man = [ + `S Manpage.s_description; + `P "$(tname) 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 ."; + `S Manpage.s_see_also; + `P "$(b,cat)(1), $(b,head)(1)" ] + in + let info = Cmd.info "tail" ~version:"v1.1.1" ~doc ~man in + Cmd.v info Term.(const tail $ lines $ follow $ verb $ pid $ files) + + +let main () = exit (Cmd.eval cmd) +let () = main () diff --git a/test/test_dupe_stdopts.ml b/test/test_dupe_stdopts.ml new file mode 100644 index 0000000..e763f54 --- /dev/null +++ b/test/test_dupe_stdopts.ml @@ -0,0 +1,40 @@ +open Cmdliner + +let sub_term = Term.const () +let main_term = + let what = Arg.(value & pos 0 (some string) None & info [] ~docv:"WHAT") in + let doc what = `Help (`Pager, what) in + Term.(ret (const doc $ what)) + +let sub_info info = info "sub" ~doc:"description of sub" +let main_info info = info "main" ~doc:"description of main" + + +module Old = struct + [@@@alert "-deprecated"] + let term_info n ~doc = Term.info n ~doc + let sub_cmd = sub_term, sub_info term_info + let main_cmd = main_term, main_info term_info + let main ~argv = Term.exit (Term.eval_choice ~argv main_cmd [sub_cmd]) +end + +module New = struct + let cmd_info n ~doc = Cmd.info n ~doc + let sub_cmd = Cmd.v (sub_info cmd_info) sub_term + let main_cmd = main_term, main_info cmd_info + let main = Cmd.group ~default:main_term (main_info cmd_info) [sub_cmd] + let main ~argv = exit (Cmd.eval ~argv main) +end + +let main () = + let argv, backend = match Array.to_list Sys.argv with + | exec :: backend :: rest -> Array.of_list (exec :: rest), backend + | [_] -> prerr_endline "Need to specify a backend: old or new"; exit 1 + | _ -> assert false + in + match backend with + | "old" -> Old.main ~argv + | "new" -> New.main ~argv + | b -> prerr_endline ("Unknown backend: " ^ b) + +let () = main () diff --git a/test/test_man.ml b/test/test_man.ml new file mode 100644 index 0000000..5d41b70 --- /dev/null +++ b/test/test_man.ml @@ -0,0 +1,101 @@ + +open Cmdliner + +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 $(mname) $(tname)" 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. $(mname) is the main term name, $(tname) is the + term name." + 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 = "print a customizable message repeatedly" in + let envs = [ Cmd.Env.info "TEST_IT" ~doc:"This is $(env) for $(tname)" ] in + let exits = (Cmd.Exit.info ~doc:"This is a $(status) for $(tname)" 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 $(mname)"; + `P "$(mname) subst at begin and end $(mname)"; + `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 $(mname) 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 aswell $(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 .";] + in + let man_xrefs = [`Page ("ascii", 7); `Main; `Tool "grep";] in + Cmd.info "man_test" ~version:"v1.1.1" ~doc ~envs ~exits ~man ~man_xrefs + +let () = exit (Cmd.eval (Cmd.v info man_test_t)) diff --git a/test/test_man_utf8.ml b/test/test_man_utf8.ml new file mode 100644 index 0000000..4aeb78b --- /dev/null +++ b/test/test_man_utf8.ml @@ -0,0 +1,9 @@ +open Cmdliner + +let nop () = print_endline "It's the manual that is of interest." + +let test_pos = + let doc = "UTF-8 test: \u{1F42B} íöüóőúűéáăîâșț ÍÜÓŐÚŰÉÁĂÎÂȘȚ 雙峰駱駝" in + Cmd.v (Cmd.info "test_pos" ~doc) Term.(const nop $ const ()) + +let () = exit (Cmd.eval test_pos) diff --git a/test/test_nest.ml b/test/test_nest.ml new file mode 100644 index 0000000..f741b2e --- /dev/null +++ b/test/test_nest.ml @@ -0,0 +1,62 @@ + +open Cmdliner + +let kind = + let doc = "Kind of entity" in + Arg.(value & opt (some string) None & info ["k";"kind"] ~doc) + +let speed = + let doc = "Movement $(docv) in m/s" in + Arg.(value & opt int 2 & info ["speed"] ~doc ~docv:"SPEED") + +let birds = + let bird = + let doc = "Use $(docv) specie." in + Arg.(value & pos 0 string "pigeon" & info [] ~doc ~docv:"BIRD") + in + let fly = + let info = Cmd.info "fly" ~doc:"Fly birds." in + Cmd.v info Term.(const (fun n v -> ()) $ bird $ speed) + in + let land' = + let info = Cmd.info "land" ~doc:"Land birds." in + Cmd.v info Term.(const (fun n -> ()) $ bird) + in + let info = Cmd.info "birds" ~doc:"Operate on birds." in + Cmd.group ~default:Term.(const (fun k -> ()) $ kind) info [fly; land'] + +let mammals = + let man_xrefs = [`Main; `Cmd "birds" ] in + let info = Cmd.info "mammals" ~doc:"Operate on mammals." ~man_xrefs in + Cmd.v info Term.(const (fun () -> ()) $ const ()) + +let fishs = + let name' = + let doc = "Use fish named $(docv)." in + Arg.(value & pos 0 (some string) None & info [] ~doc ~docv:"NAME") + in + let info = Cmd.info "fishs" ~doc:"Operate on fishs." in + Cmd.v info Term.(const (fun n -> ()) $ name') + +let camels = + let herd = + let doc = "Find in herd $(docv)." and docv = "HERD" in + let deprecated = "deprecated, herds are ignored." in + Arg.(value & pos 0 (some string) None & info [] ~deprecated ~doc ~docv) + in + let bactrian = + let deprecated = "deprecated, use nothing instead." 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 = "deprecated, use 'mammals' instead." + in + let info = Cmd.info "camels" ~deprecated ~doc:"Operate on camels." in + Cmd.v info Term.(const (fun n h -> ()) $ bactrian $ herd) + +let cmd = + let info = Cmd.info "test_nest" ~version:"X.Y.Z" in + Cmd.group info [birds; mammals; fishs; camels] + +let () = exit (Cmd.eval cmd) diff --git a/test/test_opt_req.ml b/test/test_opt_req.ml new file mode 100644 index 0000000..df29f49 --- /dev/null +++ b/test/test_opt_req.ml @@ -0,0 +1,15 @@ +open Cmdliner + +let opt o = print_endline o + +let test_opt = + let req = + Arg.(required & opt (some string) None & info ["r"; "req"] ~docv:"ARG") + in + let info = + let doc = "Test optional required arguments (don't do this)" in + Cmd.info "test_opt_req"~doc + in + Cmd.v info Term.(const opt $ req) + +let () = exit (Cmd.eval test_opt) diff --git a/test/test_pos.ml b/test/test_pos.ml new file mode 100644 index 0000000..77dc9ba --- /dev/null +++ b/test/test_pos.ml @@ -0,0 +1,13 @@ +open Cmdliner + +let pos l t r = + print_endline (String.concat "\n" (l @ ["--"; t; "--"] @ r)) + +let test_pos = + let l = Arg.(value & pos_left 2 string [] & info [] ~docv:"LEFT") in + let t = Arg.(value & pos 2 string "undefined" & info [] ~docv:"TWO") in + let r = Arg.(value & pos_right 2 string [] & info [] ~docv:"RIGHT") in + let info = Cmd.info "test_pos" ~doc:"Test pos arguments" in + Cmd.v info Term.(const pos $ l $ t $ r) + +let () = exit (Cmd.eval test_pos) diff --git a/test/test_pos_all.ml b/test/test_pos_all.ml new file mode 100644 index 0000000..5e16099 --- /dev/null +++ b/test/test_pos_all.ml @@ -0,0 +1,11 @@ +open Cmdliner + +let pos_all all = print_endline (String.concat "\n" all) + +let test_pos_all = + let docv = "THEARG" in + let all = Arg.(value & pos_all string [] & info [] ~docv) in + let info = Cmd.info "test_pos_all" ~doc:"Test pos all" in + Cmd.v info Term.(const pos_all $ all) + +let () = exit (Cmd.eval test_pos_all) diff --git a/test/test_pos_left.ml b/test/test_pos_left.ml new file mode 100644 index 0000000..47529a0 --- /dev/null +++ b/test/test_pos_left.ml @@ -0,0 +1,11 @@ +open Cmdliner + +let pos l = + print_endline (String.concat "\n" l) + +let test_pos_left = + let l = Arg.(value & pos_left 2 string [] & info [] ~docv:"LEFT") in + let info = Cmd.info "test_pos" ~doc:"Test pos left" in + Cmd.v info Term.(const pos $ l) + +let () = exit (Cmd.eval test_pos_left) diff --git a/test/test_pos_req.ml b/test/test_pos_req.ml new file mode 100644 index 0000000..1cf580b --- /dev/null +++ b/test/test_pos_req.ml @@ -0,0 +1,15 @@ +open Cmdliner + +let pos r a1 a0 a2 = + print_endline (String.concat "\n" ([a0; a1; a2; "--"] @ r)) + +let test_pos = + let req p = + let docv = Printf.sprintf "ARG%d" p in + Arg.(required & pos p (some string) None & info [] ~docv) + in + let right = Arg.(non_empty & pos_right 2 string [] & info [] ~docv:"RIGHT") in + let info = Cmd.info "test_pos_req" ~doc:"Test pos req arguments" in + Cmd.v info Term.(const pos $ right $ req 1 $ req 0 $ req 2) + +let () = exit (Cmd.eval test_pos) diff --git a/test/test_pos_rev.ml b/test/test_pos_rev.ml new file mode 100644 index 0000000..42f44d1 --- /dev/null +++ b/test/test_pos_rev.ml @@ -0,0 +1,14 @@ +open Cmdliner + +let pos l t r = + print_endline (String.concat "\n" (l @ ["--"; t; "--"] @ r)) + +let test_pos = + let rev = true in + let l = Arg.(value & pos_left ~rev 2 string [] & info [] ~docv:"LEFT") in + let t = Arg.(value & pos ~rev 2 string "undefined" & info [] ~docv:"TWO") in + let r = Arg.(value & pos_right ~rev 2 string [] & info [] ~docv:"RIGHT") in + let info = Cmd.info "test_pos" ~doc:"Test pos rev arguments" in + Cmd.v info Term.(const pos $ l $ t $ r) + +let () = exit (Cmd.eval test_pos) diff --git a/test/test_term_dups.ml b/test/test_term_dups.ml new file mode 100644 index 0000000..3b6fb93 --- /dev/null +++ b/test/test_term_dups.ml @@ -0,0 +1,19 @@ +open Cmdliner + +let dups p p_dup o o_dup = + let b = string_of_bool in + print_endline (String.concat "\n" [p; p_dup; b o; b o_dup;]) + +let test_pos = + let p = + let doc = "First pos argument should show up only once in the docs" in + Arg.(value & pos 0 string "undefined" & info [] ~doc ~docv:"POS") + in + let o = + let doc = "This should show up only once in the docs" in + Arg.(value & flag & info ["f"; "flag"] ~doc) + in + let info = Cmd.info "test_term_dups" ~doc:"Test multiple term usage" in + Cmd.v info Term.(const dups $ p $ p $ o $ o) + +let () = exit (Cmd.eval test_pos) diff --git a/test/test_with_used_args.ml b/test/test_with_used_args.ml new file mode 100644 index 0000000..eb3cca1 --- /dev/null +++ b/test/test_with_used_args.ml @@ -0,0 +1,18 @@ +open Cmdliner + +let print_args ((), args) _other = + print_endline (String.concat " " args) + +let test_pos_left = + let a = Arg.(value & flag & info ["a"; "aaa"]) in + let b = Arg.(value & opt (some string) None & info ["b"; "bbb"]) in + let c = Arg.(value & pos_all string [] & info []) in + let main = + let ignore_values _a _b _c = () in + Term.(with_used_args (const ignore_values $ a $ b $ c)) + in + let other = Arg.(value & flag & info ["other"]) in + let info = Cmd.info "test_capture" ~doc:"Test pos left" in + Cmd.v info Term.(const print_args $ main $ other) + +let () = exit (Cmd.eval test_pos_left) -- cgit v1.2.3 From b891bd8c74ee3a27b1e0c7cb65e89ac539144747 Mon Sep 17 00:00:00 2001 From: Hendrik Tews Date: Tue, 23 Jul 2019 09:38:37 +0200 Subject: install without adding execute permissions Gbp-Pq: Name install-x.patch --- Makefile | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Makefile b/Makefile index aa0a104..9d3a0ba 100644 --- a/Makefile +++ b/Makefile @@ -41,7 +41,7 @@ install: $(INSTALL-TARGETS) install-doc: $(INSTALL) -d $(DOCDIR)/odoc-pages - $(INSTALL) CHANGES.md LICENSE.md README.md $(DOCDIR) + $(INSTALL) -m 644 CHANGES.md LICENSE.md README.md $(DOCDIR) $(INSTALL) doc/index.mld doc/cli.mld doc/examples.mld doc/tutorial.mld \ doc/tool_man.mld $(DOCDIR)/odoc-pages @@ -61,18 +61,18 @@ create-libdir: $(INSTALL) -d $(LIBDIR) install-common: create-libdir - $(INSTALL) pkg/META $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) - $(INSTALL) cmdliner.opam $(LIBDIR)/opam + $(INSTALL) -m 644 pkg/META $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR) + $(INSTALL) -m 644 cmdliner.opam $(LIBDIR)/opam install-byte: create-libdir - $(INSTALL) $(BASE).cma $(LIBDIR) + $(INSTALL) -m 644 $(BASE).cma $(LIBDIR) install-native: create-libdir - $(INSTALL) $(BASE).cmxa $(BASE)$(EXT_LIB) $(wildcard $(B)/cmdliner*.cmx) \ + $(INSTALL) -m 644 $(BASE).cmxa $(BASE)$(EXT_LIB) $(wildcard $(B)/cmdliner*.cmx) \ $(LIBDIR) install-native-dynlink: create-libdir - $(INSTALL) $(BASE).cmxs $(LIBDIR) + $(INSTALL) -m 644 $(BASE).cmxs $(LIBDIR) .PHONY: all install install-doc clean build-byte build-native \ build-native-dynlink create-libdir install-common install-byte \ -- cgit v1.2.3