From ac6cb2360a8523e5f926b4c3443d5ed07d3d5b8a Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 20 Feb 2017 10:51:03 -0500 Subject: [PATCH] First cut cmdliner support (#5) Import the sources of cmdliner and rewrite the CLI of jbuilder --- LICENSE.cmdliner | 13 + src/cmdliner.ml | 301 +++++++ src/cmdliner.mli | 1635 ++++++++++++++++++++++++++++++++++++++ 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 + src/main.ml | 148 ++-- src/result.ml | 2 + 25 files changed, 4944 insertions(+), 54 deletions(-) create mode 100644 LICENSE.cmdliner create mode 100644 src/cmdliner.ml create mode 100644 src/cmdliner.mli 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 src/result.ml diff --git a/LICENSE.cmdliner b/LICENSE.cmdliner new file mode 100644 index 00000000..90fca24d --- /dev/null +++ b/LICENSE.cmdliner @@ -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/src/cmdliner.ml b/src/cmdliner.ml new file mode 100644 index 00000000..7a3ab9f6 --- /dev/null +++ b/src/cmdliner.ml @@ -0,0 +1,301 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 ret_of_result ?(usage = false) = function + | Ok v -> `Ok v + | Error (`Msg e) -> `Error (usage, e) + + let ret_result ?usage t = app (const @@ ret_of_result ?usage) t + + 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_internal_error = 124 + let exit_status_cli_error = 125 + let default_error_exits = + [ exit_info exit_status_internal_error + ~doc:"on unexpected internal errors (bugs)."; + exit_info exit_status_cli_error + ~doc:"on command line parsing errors."; ] + + 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 00000000..f68b31a2 --- /dev/null +++ b/src/cmdliner.mli @@ -0,0 +1,1635 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2011 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +(** 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 %%VERSION%% — {{:%%PKG_HOMEPAGE%% }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 int * string ] + (** 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 (sec, name)] refers to the man page [name] of section + [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, see {!Buffer.add_substitute} (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 ret_of_result : ?usage:bool -> ('a, [`Msg of string]) result -> 'a ret + (** [ret_of_result ~usage r] is + {ul + {- [`Ok v] if [r] is [Ok v].} + {- [`Error (usage, e)] if [r] is [Error (`Msg e)], [usage] defaults + to [false]}} *) + + val ret_result : ?usage:bool -> ('a, [`Msg of string]) result t -> 'a ret t + (** [ret_result ~usage r] is [app (const @@ ret_of_result ~usage) r]. *) + + 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. *) + + 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 125, an exit status for command line + parsing errors. *) + + val exit_status_internal_error : int + (** [exit_status_internal_error] is 124, 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_internal_error} if [r] is [`Error `Exn]} + {- {!exit_status_cli_error} if [r] is [`Error `Parse]}} *) + + 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. + + {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 : ?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. *) + + 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 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 unexpected internal errors (bugs). + + 125 on command line parsing errors. + +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 integrated at the end of the +documentation section name [docs] they respecively 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, to which the [doc] strings +are intergrated, 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 possible non-standard + section explicitely specified by the term as 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:"%%VERSION%%" ~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:"%%VERSION%%" ~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:"%%VERSION%%" ~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_arg.ml b/src/cmdliner_arg.ml new file mode 100644 index 00000000..0c604504 --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 00000000..eee0bb73 --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 00000000..c5d476b4 --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +(* 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 00000000..1c15ca0a --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +(** 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 00000000..1049dd0a --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 00000000..b39e0cb0 --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 00000000..5609652d --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 -> "" + | 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 -> 1, main + | `Tool tool -> 1, tool + | `Page (sec, name) -> sec, name + | `Cmd c -> + if Cmdliner_info.eval_has_choice ei c then 1, strf "%s-%s" main c else + (Format.fprintf errs "xref %s: no such term name@." c; 0, "doc-err") + in + let xref_str (sec, name) = 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 00000000..05fb6a91 --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 00000000..418dd4d9 --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + + +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 00000000..7fa60cbc --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +(** 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 00000000..ff304153 --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 int * string ] + +(* 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 00000000..36cbd979 --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +(** 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 int * string ] + +(** {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 00000000..7ea2c367 --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 00000000..cabb47a9 --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +(** 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 00000000..d333604e --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 00000000..70fa8156 --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 00000000..8458e7be --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 00000000..f41818cf --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 00000000..0aaf53f3 --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +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 00000000..01d40291 --- /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. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +(** 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/src/main.ml b/src/main.ml index 19d8a108..ead917f8 100644 --- a/src/main.ml +++ b/src/main.ml @@ -1,31 +1,7 @@ open Import open Future -let common_args = - [ "-j", Arg.Set_int Clflags.concurrency, "JOBS concurrency" - ; "-drules", Arg.Set Clflags.debug_rules, " show rules" - ; "-ddep-path", Arg.Set Clflags.debug_dep_path, " show depency path of errors" - ; "-dfindlib", Arg.Set Clflags.debug_findlib, " debug findlib stuff" - ] - -let parse_args argv msg l = - let anons = ref [] in - try - Arg.parse_argv argv (Arg.align l) (fun x -> anons := x :: !anons) msg; - List.rev !anons - with - | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2 - | Arg.Help msg -> Printf.printf "%s" msg; exit 0 - -let parse_args1 argv msg l = - match parse_args argv msg l with - | [x] -> x - | _ -> - Printf.eprintf "no enough arguments\nUsage: %s\n" msg; - exit 2 - -let internal argv = - match Array.to_list argv with +let internal = function | [_; "findlib-packages"] -> Future.Scheduler.go (Lazy.force Context.default >>= fun ctx -> @@ -68,11 +44,7 @@ let external_lib_deps ~packages = let internals = Jbuild_types.Stanza.lib_names stanzas in String_map.filter deps ~f:(fun name _ -> not (String_set.mem name internals)))) -let external_lib_deps_cmd argv = - let packages = - parse_args argv "jbuild external-lib-deps PACKAGES" - common_args - in +let external_lib_deps_cmd packages = let deps = Path.Map.fold (external_lib_deps ~packages) ~init:String_map.empty ~f:(fun ~key:_ ~data:deps acc -> Build.merge_lib_deps deps acc) @@ -82,33 +54,101 @@ let external_lib_deps_cmd argv = | Required -> Printf.printf "%s\n" n | Optional -> Printf.printf "%s (optional)\n" n) -let main () = - let argv = Sys.argv in - let argc = Array.length argv in - let compact () = - Array.append - [|sprintf "%s %s" argv.(0) argv.(1)|] - (Array.sub argv ~pos:2 ~len:(argc - 2)) - in - if argc >= 2 then - match argv.(1) with - | "internal" -> internal (compact ()) - | "build-package" -> - let pkg = - parse_args1 (compact ()) "jbuild build-package PACKAGE" - common_args - in - Future.Scheduler.go - (setup () >>= fun (bs, _, _) -> - Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")]) - | "external-lib-deps" -> - external_lib_deps_cmd (compact ()) - | _ -> - let targets = parse_args argv "jbuild TARGETS" common_args in +let build_package pkg = + Future.Scheduler.go + (setup () >>= fun (bs, _, _) -> + Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")]) + +module Cli = struct + open Cmdliner + + let internal = + let doc = "internal" in + let name_ = Arg.info [] in + ( Term.(const internal $ Arg.(non_empty & pos_all string [] name_)) + , Term.info "internal" ~doc) + + type common = + { concurrency: int + ; debug_rules: bool + ; debug_dep_path: bool + ; debug_findlib: bool + } + + let set_common c = + Clflags.concurrency := c.concurrency; + Clflags.debug_rules := c.debug_rules; + Clflags.debug_dep_path := c.debug_dep_path; + Clflags.debug_findlib := c.debug_findlib + + let copts_sect = "COMMON OPTIONS" + let help_secs = + [ `S copts_sect + ; `P "These options are common to all commands." + ; `S "MORE HELP" + ; `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command." + ;`Noblank + ; `S "BUGS" + ; `P "Check bug reports at https://github.com/janestreet/jbuilder/issues" + ] + + let common = + let make concurrency debug_rules debug_dep_path debug_findlib = + { concurrency ; debug_rules ; debug_dep_path ; debug_findlib } in + let docs = copts_sect in + let concurrency = + Arg.(value & opt int !Clflags.concurrency & info ["j"] ~docs) in + let drules = Arg.(value & flag & info ["drules"] ~docs) in + let ddep_path = Arg.(value & flag & info ["ddep-path"] ~docs) in + let dfindlib = Arg.(value & flag & info ["dfindlib"] ~docs) in + Term.(const make $ concurrency $ drules $ ddep_path $ dfindlib) + + let build_package = + let doc = "build-package" in + let name_ = Arg.info [] in + let go common pkg = + set_common common; + build_package pkg in + ( Term.(const go + $ common + $ Arg.(required & pos 0 (some string) None name_)) + , Term.info "build-package" ~doc ~man:help_secs) + + let external_lib_deps = + let doc = "external-lib-deps" in + let name_ = Arg.info [] in + let go common packages = + set_common common; + external_lib_deps_cmd packages in + ( Term.(const go + $ common + $ Arg.(non_empty & pos_all string [] name_)) + , Term.info "external-lib-deps" ~doc ~man:help_secs) + + let build_targets = + let doc = "build" in + let name_ = Arg.info [] in + let go common targets = + set_common common; Future.Scheduler.go (setup () >>= fun (bs, _, ctx) -> let targets = List.map targets ~f:(Path.relative ctx.build_dir) in - Build_system.do_build_exn bs targets) + Build_system.do_build_exn bs targets) in + ( Term.(const go + $ common + $ Arg.(non_empty & pos_all string [] name_)) + , Term.info "build" ~doc ~man:help_secs) + + let all = + [ internal ; build_package ; external_lib_deps ; build_targets ] + + let main () = + match Term.eval_choice build_targets all with + | `Error _ -> exit 1 + | _ -> exit 0 +end + +let main = Cli.main let report_error ?(map_fname=fun x->x) ppf exn ~backtrace = match exn with diff --git a/src/result.ml b/src/result.ml new file mode 100644 index 00000000..8ec16b72 --- /dev/null +++ b/src/result.ml @@ -0,0 +1,2 @@ + +type nonrec ('ok, 'err) result = ('ok, 'err) result