First cut cmdliner support (#5)
Import the sources of cmdliner and rewrite the CLI of jbuilder
This commit is contained in:
Rudi Grinberg
Jérémie Dimino
parent
1b84d5df1f
commit
ac6cb2360a
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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 "@[<v>%a@]" (pp_plain_blocks ~errs subst) text
|
||||
|
||||
(* Groff output *)
|
||||
|
||||
let markup_to_groff ~errs b s =
|
||||
let max_i = String.length s - 1 in
|
||||
let flush start stop = match start > max_i with
|
||||
| true -> ()
|
||||
| false -> Buffer.add_substring b s start (stop - start + 1)
|
||||
in
|
||||
let need_escape = function '.' | '\'' | '-' | '\\' -> true | _ -> false in
|
||||
let escape b c = Printf.bprintf b "\\N'%d'" (Char.code c) in
|
||||
let rec end_text start i = Buffer.add_string b "\\fR"; loop start i
|
||||
and loop start i =
|
||||
if i > max_i then flush start max_i else
|
||||
let next = i + 1 in
|
||||
match s.[i] with
|
||||
| '\\' ->
|
||||
flush start (i - 1);
|
||||
add_markup_esc ~errs loop b s start next need_escape escape
|
||||
| '$' ->
|
||||
if next > max_i then err_unescaped ~errs '$' s else
|
||||
begin match s.[next] with
|
||||
| '(' ->
|
||||
let min = next + 2 in
|
||||
if min > max_i then (err_unclosed ~errs s; loop start next) else
|
||||
begin match s.[min] with
|
||||
| ',' ->
|
||||
let start_data = min + 1 in
|
||||
flush start (i - 1);
|
||||
begin match s.[min - 1] with
|
||||
| 'i' -> Buffer.add_string b "\\fI"
|
||||
| 'b' -> Buffer.add_string b "\\fB"
|
||||
| markup -> err_markup ~errs markup s
|
||||
end;
|
||||
add_markup_text ~errs end_text b s start_data need_escape escape
|
||||
| _ -> err_malformed ~errs s; loop start next
|
||||
end
|
||||
| _ -> err_unescaped ~errs '$' s; flush start (i - 1); loop next next
|
||||
end
|
||||
| c when markup_need_esc c ->
|
||||
err_unescaped ~errs c s; flush start (i - 1); loop next next
|
||||
| c when need_escape c ->
|
||||
flush start (i - 1); escape b c; loop next next
|
||||
| c -> loop start next
|
||||
in
|
||||
(Buffer.clear b; loop 0 0; Buffer.contents b)
|
||||
|
||||
let doc_to_groff ~errs ~subst b s =
|
||||
markup_to_groff ~errs b (subst_vars ~errs ~subst b s)
|
||||
|
||||
let pp_groff_blocks ~errs subst ppf text =
|
||||
let buf = Buffer.create 1024 in
|
||||
let markup t = doc_to_groff ~errs ~subst buf t in
|
||||
let pp_tokens ppf t = 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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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 "@[<v>%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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
|
|
@ -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.
|
||||
---------------------------------------------------------------------------*)
|
||||
148
src/main.ml
148
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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
|
||||
type nonrec ('ok, 'err) result = ('ok, 'err) result
|
||||
Loading…
Reference in New Issue