(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) open Error_monad type ('p, 'ctx) parameter = { converter: ('ctx -> string -> 'p tzresult Lwt.t) ; autocomplete: ('ctx -> string list tzresult Lwt.t) option } let parameter ?autocomplete converter = { converter ; autocomplete } type label = { long : string ; short : char option } type ('a, 'ctx) arg = | Arg : { doc : string ; label : label ; placeholder : string ; kind : ('p, 'ctx) parameter } -> ('p option, 'ctx) arg | DefArg : { doc : string ; label : label ; placeholder : string ; kind : ('p, 'ctx) parameter ; default : string } -> ('p, 'ctx) arg | Switch : { label : label ; doc : string } -> (bool, 'ctx) arg | Constant : 'a -> ('a, 'ctx) arg type ('a, 'arg) args = | NoArgs : (unit, 'args) args | AddArg : ('a, 'args) arg * ('b, 'args) args -> ('a * 'b, 'args) args (* A simple structure for command interpreters. This is more generic than the exported one, see end of file. *) type ('a, 'ctx) params = | Prefix : string * ('a, 'ctx) params -> ('a, 'ctx) params | Param : string * string * ('p, 'ctx) parameter * ('a, 'ctx) params -> ('p -> 'a, 'ctx) params | Stop : ('ctx -> unit tzresult Lwt.t, 'ctx) params | Seq : string * string * ('p, 'ctx) parameter -> ('p list -> 'ctx -> unit tzresult Lwt.t, 'ctx) params type (_, _) options = Argument : { spec : ('a, 'arg) args ; converter : 'a -> 'b } -> ('b, 'arg) options (* A command group *) type group = { name : string ; title : string } (* A command wraps a callback with its type and info *) type 'arg command = | Command : { params : ('a, 'iarg) params ; options : ('b, 'iarg) options ; handler : 'b -> 'a ; desc : string ; group : group option ; conv : 'arg -> 'iarg } -> 'arg command type error += Bad_argument of int * string type error += Unterminated_command : string list * 'ctx command list -> error type error += Command_not_found : string list * 'ctx command list -> error type error += Unknown_option : string * 'ctx command option -> error type error += Option_expected_argument : string * 'ctx command option -> error type error += Bad_option_argument : string * 'ctx command option -> error type error += Multiple_occurences : string * 'ctx command option -> error type error += Extra_arguments : string list * 'ctx command -> error let trim s = (* config-file wokaround *) TzString.split '\n' s |> List.map String.trim |> String.concat "\n" let print_desc ppf doc = let short, long = try let len = String.index doc '\n' in String.sub doc 0 len, Some (String.sub doc (len + 1) (String.length doc - len - 1)) with _ -> doc, None in match long with | None -> Format.fprintf ppf "%s" short | Some doc -> Format.fprintf ppf "%s@{@\n @[%a@]@}" short Format.pp_print_text doc let print_label ppf = function | { long ; short = None } -> Format.fprintf ppf "--%s" long | { long ; short = Some short } -> Format.fprintf ppf "-%c --%s" short long let print_options_detailed (type ctx) = let help_option : type a.Format.formatter -> (a, ctx) arg -> unit = fun ppf -> function | Arg { label ; placeholder ; doc ; _ } -> Format.fprintf ppf "@{%a <%s>@}: %a" print_label label placeholder print_desc doc ; | DefArg { label ; placeholder ; doc ; default ; _ } -> Format.fprintf ppf "@{%a <%s>@}: %a" print_label label placeholder print_desc (doc ^ "\nDefaults to `" ^ default ^ "`.") | Switch { label ; doc } -> Format.fprintf ppf "@{%a@}: %a" print_label label print_desc doc | Constant _ -> () in let rec help : type b. Format.formatter -> (b, ctx) args -> unit = fun ppf -> function | NoArgs -> () | AddArg (arg, NoArgs) -> Format.fprintf ppf "%a" help_option arg | AddArg (arg, rest) -> Format.fprintf ppf "%a@,%a" help_option arg help rest in help let has_args : type a ctx. (a, ctx) args -> bool = function | NoArgs -> false | AddArg (_,_) -> true let print_options_brief (type ctx) = let help_option : type a. Format.formatter -> (a, ctx) arg -> unit = fun ppf -> function | DefArg { label ; placeholder ; _ } -> Format.fprintf ppf "[@{%a <%s>@}]" print_label label placeholder | Arg { label ; placeholder ; _ } -> Format.fprintf ppf "[@{%a <%s>@}]" print_label label placeholder | Switch { label ; _ } -> Format.fprintf ppf "[@{%a@}]" print_label label | Constant _ -> () in let rec help : type b. Format.formatter -> (b, ctx) args -> unit = fun ppf -> function | NoArgs -> () | AddArg (arg, NoArgs) -> Format.fprintf ppf "%a" help_option arg | AddArg (arg, rest) -> Format.fprintf ppf "%a@ %a" help_option arg help rest in help let print_highlight highlight_strings formatter str = let rec print_string = function | [] -> Format.fprintf formatter "%s" str | regex :: tl -> begin match Re.Str.full_split regex str with | [] | [ Re.Str.Text _ ] -> print_string tl | list -> List.iter (function | Re.Str.Text text -> Format.fprintf formatter "%s" text | Re.Str.Delim delimiter -> Format.fprintf formatter "@{%s@}" delimiter) list end in print_string (List.map Re.Str.regexp_string highlight_strings) let print_commandline ppf (highlights, options, args) = let rec print : type a ctx. Format.formatter -> (a, ctx) params -> unit = fun ppf -> function | Stop -> Format.fprintf ppf "%a" print_options_brief options | Seq (n, _, _) when not (has_args options) -> Format.fprintf ppf "[@{%s@}...]" n | Seq (n, _, _) -> Format.fprintf ppf "[@{%s@}...] %a" n print_options_brief options | Prefix (n, Stop) when not (has_args options) -> Format.fprintf ppf "@{%a@}" (print_highlight highlights) n | Prefix (n, next) -> Format.fprintf ppf "@{%a@} %a" (print_highlight highlights) n print next | Param (n, _, _, Stop) when not (has_args options) -> Format.fprintf ppf "@{%s@}" n | Param (n, _, _, next) -> Format.fprintf ppf "@{%s@} %a" n print next in Format.fprintf ppf "@{%a@}" print args let rec print_params_detailed : type a b ctx. (b, ctx) args -> Format.formatter -> (a, ctx) params -> unit = fun spec ppf -> function | Stop -> print_options_detailed ppf spec | Seq (n, desc, _) -> Format.fprintf ppf "@{%s@}: %a" n print_desc (trim desc) ; begin match spec with | NoArgs -> () | _ -> Format.fprintf ppf "@,%a" print_options_detailed spec end | Prefix (_, next) -> print_params_detailed spec ppf next | Param (n, desc, _, Stop) -> Format.fprintf ppf "@{%s@}: %a" n print_desc (trim desc); begin match spec with | NoArgs -> () | _ -> Format.fprintf ppf "@,%a" print_options_detailed spec end | Param (n, desc, _, next) -> Format.fprintf ppf "@{%s@}: %a@,%a" n print_desc (trim desc) (print_params_detailed spec) next let contains_params_args : type arg ctx. (arg, ctx) params -> (_, ctx) args -> bool = fun params args -> let rec help : (arg, ctx) params -> bool = function | Stop -> has_args args | Seq (_, _, _) -> true | Prefix (_, next) -> help next | Param (_, _, _, _) -> true in help params let print_command : type ctx. ?prefix:(Format.formatter -> unit -> unit) -> ?highlights:string list -> Format.formatter -> ctx command -> unit = fun ?(prefix = (fun _ () -> ())) ?(highlights=[]) ppf (Command { params ; desc ; options = Argument { spec ; _ } ; _ }) -> if contains_params_args params spec then Format.fprintf ppf "@{%a%a@{@,@{%a@,%a@}@}@}" prefix () print_commandline (highlights, spec, params) print_desc desc (print_params_detailed spec) params else Format.fprintf ppf "@{%a%a@{@,@{%a@}@}@}" prefix () print_commandline (highlights, spec, params) print_desc desc type ex_command = Ex : _ command -> ex_command let group_commands commands = let (grouped, ungrouped) = List.fold_left (fun (grouped, ungrouped) (Ex (Command { group ; _ }) as command) -> match group with | None -> (grouped, command :: ungrouped) | Some group -> match List.find_opt (fun ({ name ; _ }, _) -> group.name = name) grouped with | None -> ((group, ref [ command ]) :: grouped, ungrouped) | Some ({ title ; _ }, r) -> if title <> group.title then invalid_arg "Clic.usage: duplicate group name" ; r := command :: !r ; (grouped, ungrouped)) ([], []) commands in List.map (fun (g, c) -> (g, List.rev !c)) (match ungrouped with | [] -> grouped | l -> (grouped @ [ { name = "misc" ; title = "Miscellaneous commands" }, ref l ])) let print_group print_command ppf ({ title ; _ }, commands) = Format.fprintf ppf "@{%s@}@,@{<list>%a@}" title (Format.pp_print_list print_command) commands type formatter_state = Format.formatter_out_functions * Format.formatter_tag_functions * bool type format = Plain | Ansi | Html type verbosity = Terse | Short | Details | Full let setup_formatter ppf format verbosity = let skip = ref false in let orig_out_functions, _, _ as orig_state = Format.pp_get_formatter_out_functions ppf (), Format.pp_get_formatter_tag_functions ppf (), Format.pp_get_print_tags ppf () in begin Format.pp_print_flush ppf () ; Format.pp_set_formatter_out_functions ppf { out_string = (fun s b a -> if s = "\000\000\000" then skip := true else if s = "\255\255\255" then skip := false else if not !skip then orig_out_functions.out_string s b a) ; out_spaces = (fun n -> if not !skip then orig_out_functions.out_spaces n) ; out_newline = (fun () -> if not !skip then orig_out_functions.out_newline ()) ; out_flush = (fun () -> if not !skip then orig_out_functions.out_flush ()) ; out_indent = orig_out_functions.out_indent } ; let levels = ref [] in let setup_level (level, op) = if op level verbosity then Format.fprintf ppf "@<0>%s" "\255\255\255" else Format.fprintf ppf "@<0>%s" "\000\000\000" in let push_level level = levels := level :: !levels ; setup_level level in let pop_level () = match !levels with | _ :: level :: rest -> levels := level :: rest ; setup_level level | [ _ ] | [] -> Pervasives.failwith "Clic: unclosed verbosity tag" in push_level (Terse, (<=)) ; let push_level_tag tag = let push op = function | "full" -> push_level (Full, op) | "details" -> push_level (Details, op) | "short" -> push_level (Short, op) | "terse" -> push_level (Terse, op) | tag -> Pervasives.failwith ("Clic: invalid semantic tag <" ^ tag ^ ">") in if String.length tag > 0 && String.get tag 0 = '=' then push (=) (String.sub tag 1 (String.length tag - 1)) else if String.length tag > 0 && String.get tag 0 = '-' then push (>) (String.sub tag 1 (String.length tag - 1)) else push (<=) tag in let pop_level_tag = function | "full" | "details" | "short" | "terse" | "-full" | "-details" | "-short" | "-terse" | "=full" | "=details" | "=short" | "=terse" -> pop_level () | tag -> Pervasives.failwith ("Clic: invalid semantic tag <" ^ tag ^ ">") in match format with | Ansi -> let color_num = function | `Auto -> None | `Black -> Some 0 | `Red -> Some 1 | `Green -> Some 2 | `Yellow -> Some 3 | `Blue -> Some 4 | `Magenta -> Some 5 | `Cyan -> Some 6 | `White -> Some 7 in let ansi_format ppf (fg, bg, b, u) = Format.fprintf ppf "@<0>%s" "\027[0m" ; match (match color_num fg with Some n -> [ string_of_int (30 + n) ] | None -> []) @ (match color_num bg with Some n -> [ string_of_int (40 + n) ] | None -> []) @ (if b then [ "1" ] else []) @ (if u then [ "4" ] else []) with | [] -> () | l -> Format.fprintf ppf "@<0>%s" ("\027[" ^ String.concat ";" l ^ "m") in let ansi_stack = ref [ (`Auto, `Auto, false, false) ] in let push_ansi_format (fg, bg, b, u) = let format = match !ansi_stack with | (pfg, pbg, pb, pu) :: _ -> (Option.unopt ~default: pfg fg, Option.unopt ~default: pbg bg, pb || b, pu || u) | [] -> assert false in ansi_stack := format :: !ansi_stack ; Format.fprintf ppf "@<0>%a" ansi_format format in let pop_ansi_format () = Format.fprintf ppf "@<0>%s" "\027[0m" ; match !ansi_stack with | _ :: format :: rest -> ansi_stack := format :: rest ; Format.fprintf ppf "@<0>%a" ansi_format format | [ _ ] | [] -> Pervasives.failwith "Clic: unclosed ansi format" in Format.pp_set_formatter_tag_functions ppf { mark_open_tag = (fun _ -> "") ; mark_close_tag = (fun _ -> "") ; print_open_tag = begin function | "title" -> push_ansi_format (None, None, true, true) | "commandline" -> Format.fprintf ppf "@[<hov 4>" | "commanddoc" -> Format.fprintf ppf " @[<v 0>" | "opt" -> push_ansi_format (Some `Green, None, false, false) | "arg" -> push_ansi_format (Some `Yellow, None, false, false) ; Format.fprintf ppf "<" | "kwd" -> push_ansi_format (None, None, false, true) | "error" -> push_ansi_format (Some `Red, None, true, true) | "warning" -> push_ansi_format (Some `Yellow, None, true, true) | "hilight" -> push_ansi_format (Some `White, Some `Yellow, true, true) | "list" -> Format.fprintf ppf " @[<v 0>" | "command" -> Format.fprintf ppf "@[<v 0>" | "document" -> Format.fprintf ppf "@[<v 0>" | other -> push_level_tag other end ; print_close_tag = begin function | "title" -> Format.fprintf ppf ":" ; pop_ansi_format () | "commandline" -> Format.fprintf ppf "@]" | "commanddoc" -> Format.fprintf ppf "@]" | "opt" -> pop_ansi_format () | "arg" -> Format.fprintf ppf ">" ; pop_ansi_format () | "kwd" -> pop_ansi_format () | "error" -> pop_ansi_format () | "warning" -> pop_ansi_format () | "hilight" -> pop_ansi_format () | "command" | "list" -> Format.fprintf ppf "@]" | "document" -> Format.fprintf ppf "@]" | other -> pop_level_tag other end } ; Format.pp_set_print_tags ppf true | Plain -> Format.pp_set_formatter_tag_functions ppf { mark_open_tag = (fun _ -> "") ; mark_close_tag = (fun _ -> "") ; print_open_tag = begin function | "title" -> () | "commandline" -> Format.fprintf ppf "@[<hov 4>" | "commanddoc" -> Format.fprintf ppf " @[<v 0>" | "opt" -> () | "arg" -> Format.fprintf ppf "<" | "kwd" -> () | "hilight" -> () | "error" -> () | "warning" -> () | "list" -> Format.fprintf ppf " @[<v 0>" | "command" -> Format.fprintf ppf "@[<v 0>" | "document" -> Format.fprintf ppf "@[<v 0>" | other -> push_level_tag other end ; print_close_tag = begin function | "title" -> Format.fprintf ppf ":" | "commandline" -> Format.fprintf ppf "@]" | "commanddoc" -> Format.fprintf ppf "@]" | "opt" -> () | "arg" -> Format.fprintf ppf ">" | "kwd" -> () | "error" -> () | "warning" -> () | "hilight" -> () | "command" | "list" -> Format.fprintf ppf "@]" | "document" -> Format.fprintf ppf "@]" | other -> pop_level_tag other end } ; Format.pp_set_print_tags ppf true | Html -> Format.pp_set_formatter_tag_functions ppf { mark_open_tag = (fun _ -> "") ; mark_close_tag = (fun _ -> "") ; print_open_tag = begin function | "title" -> Format.fprintf ppf "\003h3\004" | "commandline" -> Format.fprintf ppf "\003div class='cmdline'\004@[<h>" | "commanddoc" -> Format.fprintf ppf "\003div class='cmddoc'\004" | "opt" -> Format.fprintf ppf "\003span class='opt'\004" | "arg" -> Format.fprintf ppf "\003span class='arg'\004" | "kwd" -> Format.fprintf ppf "\003span class='kwd'\004" | "hilight" -> () | "error" -> () | "warning" -> () | "list" -> Format.fprintf ppf "\003ul\004@\n" | "command" -> Format.fprintf ppf "\003li\004@\n" | "document" -> Format.fprintf ppf "@[<v 0>\003style\004\ .cmdline { font-family: monospace }\ .cmddoc { white-space: pre-wrap ; font-family: monospace; line-height: 170%%; margin: 0 0 20px 0 }\ .cmdline { background: #343131; padding: 2px 8px; border-radius:10px; color: white; margin: 5px; }\ .cmdline+.cmddoc { margin: -5px 5px 0 20px; padding: 5px }\ .opt,.arg { background: #343131; font-weight: bold; padding: 2px 4px; border-radius:5px; }\ .kwd { font-weight: bold; } .opt { color:#CF0; background: #460; } .arg { color: #CEF; background: #369; }\ \003/style\004@\n" ; | other -> push_level_tag other end ; print_close_tag = begin function | "title" -> Format.fprintf ppf "\003/h3\004@\n" | "commandline" -> Format.fprintf ppf "@]\003/div\004@\n" | "commanddoc" -> Format.fprintf ppf "\003/div\004@\n" | "opt" | "arg" | "kwd" -> Format.fprintf ppf "\003/span\004" | "error" | "warning" | "hilight" -> () | "list" -> Format.fprintf ppf "\003/ul\004@\n" | "command" -> Format.fprintf ppf "\003/li\004@\n" | "document" -> Format.fprintf ppf "@]" | other -> pop_level_tag other end } ; let orig_out_functions = Format.pp_get_formatter_out_functions ppf () in Format.pp_set_formatter_out_functions ppf { orig_out_functions with out_string = (fun s i j -> let buf = Buffer.create (j - i) in for n = i to j - 1 do match String.get s n with | '\003' -> Buffer.add_char buf '<' | '\004' -> Buffer.add_char buf '>' | '>' -> Buffer.add_string buf ">" | '<' -> Buffer.add_string buf "<" | c -> Buffer.add_char buf c done ; let s' = Buffer.contents buf in orig_out_functions.out_string s' 0 (String.length s'))} ; Format.pp_set_print_tags ppf true end ; orig_state let restore_formatter ppf (out_functions, tag_functions, tags) = Format.pp_print_flush ppf () ; Format.pp_set_formatter_out_functions ppf out_functions ; Format.pp_set_formatter_tag_functions ppf tag_functions ; Format.pp_set_print_tags ppf tags let usage_internal ppf ~executable_name ~global_options ?(highlights=[]) commands = let by_group = group_commands commands in let (Argument { spec ; _ }) = global_options in let print_groups = Format.pp_print_list ~pp_sep: (fun ppf () -> Format.fprintf ppf "@,@,") (print_group (fun ppf (Ex command) -> print_command ?prefix:None ~highlights ppf command)) in Format.fprintf ppf "@{<document>@{<title>Usage@}@,\ @{<list>\ @{<command>@{<commandline>\ %s [@{<opt>global options@}] @{<kwd>command@} [@{<opt>command options@}]@}@}@,\ @{<command>@{<commandline>\ %s @{<opt>--help@} (for global options)@}@}@,\ @{<command>@{<commandline>\ %s [@{<opt>global options@}] @{<kwd>command@} @{<opt>--help@} (for command options)@}@}\ @}@,@,\ @{<title>To browse the documentation@}@,\ @{<list>\ @{<command>@{<commandline>\ %s [@{<opt>global options@}] @{<kwd>man@} (for a list of commands)@}@}@,\ @{<command>@{<commandline>\ %s [@{<opt>global options@}] @{<kwd>man@} @{<opt>-v 3@} (for the full manual)@}@}\ @}@,@,\ @{<title>Global options (must come before the command)@}@,\ @{<commanddoc>%a@}%a\ %a@}@." executable_name executable_name executable_name executable_name executable_name print_options_detailed spec (fun ppf () -> if by_group <> [] then Format.fprintf ppf "@,@,") () print_groups by_group let constant c = Constant c let arg ~doc ?short ~long ~placeholder kind = Arg { doc ; label = { long ; short } ; placeholder ; kind } let default_arg ~doc ?short ~long ~placeholder ~default kind = DefArg { doc ; placeholder ; label = { long ; short } ; kind ; default } let switch ~doc ?short ~long () = Switch { doc ; label = { long ; short } } let parse_arg : type a ctx. ?command:_ command -> (a, ctx) arg -> string list TzString.Map.t -> ctx -> a tzresult Lwt.t = fun ?command spec args_dict ctx -> match spec with | Arg { label = { long ; short = _ } ; kind = { converter ; _ } ; _ } -> begin match TzString.Map.find_opt long args_dict with | None | Some [] -> return_none | Some [ s ] -> (trace (Bad_option_argument ("--" ^ long, command)) (converter ctx s)) >>|? fun x -> Some x | Some (_ :: _) -> fail (Multiple_occurences ("--" ^ long, command)) end | DefArg { label = { long ; short = _ } ; kind = { converter ; _ } ; default ; _ } -> converter ctx default >>= fun default -> begin match default with | Ok x -> return x | Error _ -> invalid_arg (Format.sprintf "Value provided as default for '%s' could not be parsed by converter function." long) end >>=? fun default -> begin match TzString.Map.find_opt long args_dict with | None | Some [] -> return default | Some [ s ] -> (trace (Bad_option_argument (long, command)) (converter ctx s)) | Some (_ :: _) -> fail (Multiple_occurences (long, command)) end | Switch { label = { long ; short = _ } ; _ } -> begin match TzString.Map.find_opt long args_dict with | None | Some [] -> return_false | Some [ _ ] -> return_true | Some (_ :: _) -> fail (Multiple_occurences (long, command)) end | Constant c -> return c (* Argument parsing *) let rec parse_args : type a ctx. ?command:_ command -> (a, ctx) args -> string list TzString.Map.t -> ctx -> a tzresult Lwt.t = fun ?command spec args_dict ctx -> match spec with | NoArgs -> return_unit | AddArg (arg, rest) -> parse_arg ?command arg args_dict ctx >>=? fun arg -> parse_args ?command rest args_dict ctx >>|? fun rest -> (arg, rest) let empty_args_dict = TzString.Map.empty let rec make_arities_dict : type a b. (a, b) args -> (int * string) TzString.Map.t -> (int * string) TzString.Map.t = fun args acc -> match args with | NoArgs -> acc | AddArg (arg, rest) -> let recur { long ; short } num = (match short with | None -> acc | Some c -> TzString.Map.add ("-" ^ String.make 1 c) (num, long) acc) |> TzString.Map.add ("-" ^ long) (num, long) |> TzString.Map.add ("--" ^ long) (num, long) |> make_arities_dict rest in match arg with | Arg { label ; _ } -> recur label 1 | DefArg { label ; _ } -> recur label 1 | Switch { label ; _ } -> recur label 0 | Constant _c -> make_arities_dict rest acc type error += Help : 'a command option -> error let check_help_flag ?command = function | ("-h" | "--help") :: _ -> fail (Help command) | _ -> return_unit let add_occurrence long value acc = match TzString.Map.find_opt long acc with | Some v -> TzString.Map.add long v acc | None -> TzString.Map.add long [ value ] acc let make_args_dict_consume ?command spec args = let rec make_args_dict completing arities acc args = check_help_flag ?command args >>=? fun () -> match args with | [] -> return (acc, []) | arg :: tl -> if String.length arg > 0 && String.get arg 0 = '-' then if TzString.Map.mem arg arities then let arity, long = TzString.Map.find arg arities in check_help_flag ?command tl >>=? fun () -> match arity, tl with | 0, tl' -> make_args_dict completing arities (add_occurrence long "" acc) tl' | 1, value :: tl' -> make_args_dict completing arities (add_occurrence long value acc) tl' | 1, [] when completing -> return (acc, []) | 1, [] -> fail (Option_expected_argument (arg, None)) | _, _ -> raise (Failure "cli_entries: Arguments with arity not equal to 1 or 0 not supported") else fail (Unknown_option (arg, None)) else return (acc, args) in make_args_dict false (make_arities_dict spec TzString.Map.empty) TzString.Map.empty args let make_args_dict_filter ?command spec args = let rec make_args_dict arities (dict, other_args) args = check_help_flag ?command args >>=? fun () -> match args with | [] -> return (dict, other_args) | arg :: tl -> if TzString.Map.mem arg arities then let arity, long = TzString.Map.find arg arities in check_help_flag ?command tl >>=? fun () -> match arity, tl with | 0, tl -> make_args_dict arities (add_occurrence long "" dict, other_args) tl | 1, value :: tl' -> make_args_dict arities (add_occurrence long value dict, other_args) tl' | 1, [] -> fail (Option_expected_argument (arg, command)) | _, _ -> raise (Failure "cli_entries: Arguments with arity not equal to 1 or 0 not supported") else make_args_dict arities (dict, arg :: other_args) tl in make_args_dict (make_arities_dict spec TzString.Map.empty) (TzString.Map.empty, []) args >>|? fun (dict, remaining) -> (dict, List.rev remaining) let (>>) arg1 arg2 = AddArg (arg1, arg2) let args1 spec = Argument { spec = spec >> NoArgs; converter = fun (arg, ()) -> arg } let args2 spec1 spec2 = Argument { spec = spec1 >> (spec2 >> NoArgs) ; converter = fun (arg1, (arg2, ())) -> arg1, arg2 } let args3 spec1 spec2 spec3 = Argument { spec = spec1 >> (spec2 >> (spec3 >> NoArgs)) ; converter = fun (arg1, (arg2, (arg3, ()))) -> arg1, arg2, arg3 } let args4 spec1 spec2 spec3 spec4 = Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> NoArgs))) ; converter = fun (arg1, (arg2, (arg3, (arg4, ())))) -> arg1, arg2, arg3, arg4 } let args5 spec1 spec2 spec3 spec4 spec5 = Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> NoArgs)))) ; converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, ()))))) -> arg1, arg2, arg3, arg4, arg5 } let args6 spec1 spec2 spec3 spec4 spec5 spec6 = Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> NoArgs))))) ; converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, ())))))) -> arg1, arg2, arg3, arg4, arg5, spec6 } let args7 spec1 spec2 spec3 spec4 spec5 spec6 spec7 = Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> NoArgs)))))) ; converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, ()))))))) -> arg1, arg2, arg3, arg4, arg5, spec6, spec7 } let args8 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 = Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> (spec8 >> NoArgs))))))) ; converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, ())))))))) -> arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8 } let args9 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 = Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> (spec8 >> (spec9 >> NoArgs)))))))) ; converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, (spec9, ()))))))))) -> arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9 } let args10 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 = Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> (spec8 >> (spec9 >> (spec10 >> NoArgs))))))))) ; converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, (spec9, (spec10, ())))))))))) -> arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10 } let args11 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 spec11 = Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> (spec8 >> (spec9 >> (spec10 >> (spec11 >> NoArgs)))))))))) ; converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, (spec9, (spec10, (spec11, ()))))))))))) -> arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10, spec11 } let args12 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 spec11 spec12 = Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> (spec8 >> (spec9 >> (spec10 >> (spec11 >> (spec12 >> NoArgs))))))))))) ; converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, (spec9, (spec10, (spec11, (spec12, ())))))))))))) -> arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10, spec11, spec12 } let args13 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 spec11 spec12 spec13 = Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> (spec8 >> (spec9 >> (spec10 >> (spec11 >> (spec12 >> (spec13 >> NoArgs)))))))))))) ; converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, (spec9, (spec10, (spec11, (spec12, (spec13, ()))))))))))))) -> arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10, spec11, spec12, spec13 } let args14 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 spec11 spec12 spec13 spec14 = Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> (spec8 >> (spec9 >> (spec10 >> (spec11 >> (spec12 >> (spec13 >> (spec14 >> NoArgs))))))))))))) ; converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, (spec9, (spec10, (spec11, (spec12, (spec13, (spec14, ())))))))))))))) -> arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10, spec11, spec12, spec13, spec14 } let args15 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 spec11 spec12 spec13 spec14 spec15 = Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> (spec8 >> (spec9 >> (spec10 >> (spec11 >> (spec12 >> (spec13 >> (spec14 >> (spec15 >> NoArgs)))))))))))))) ; converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, (spec9, (spec10, (spec11, (spec12, (spec13, (spec14, (spec15, ()))))))))))))))) -> arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10, spec11, spec12, spec13, spec14, spec15 } let args16 spec1 spec2 spec3 spec4 spec5 spec6 spec7 spec8 spec9 spec10 spec11 spec12 spec13 spec14 spec15 spec16 = Argument { spec = spec1 >> (spec2 >> (spec3 >> (spec4 >> (spec5 >> (spec6 >> (spec7 >> (spec8 >> (spec9 >> (spec10 >> (spec11 >> (spec12 >> (spec13 >> (spec14 >> (spec15 >> (spec16 >> NoArgs))))))))))))))) ; converter = fun (arg1, (arg2, (arg3, (arg4, (arg5, (spec6, (spec7, (spec8, (spec9, (spec10, (spec11, (spec12, (spec13, (spec14, (spec15, (spec16, ())))))))))))))))) -> arg1, arg2, arg3, arg4, arg5, spec6, spec7, spec8, spec9, spec10, spec11, spec12, spec13, spec14, spec15, spec16 } (* Some combinators for writing commands concisely. *) let param ~name ~desc kind next = Param (name, desc, kind, next) let seq_of_param param = match param Stop with | Param (n, desc, parameter, Stop) -> Seq (n, desc, parameter) | _ -> invalid_arg "Clic.seq_of_param" let prefix keyword next = Prefix (keyword, next) let rec fixed = function [] -> Stop | n :: r -> Prefix (n, fixed r) let rec prefixes p next = match p with [] -> next | n :: r -> Prefix (n, prefixes r next) let stop = Stop let no_options = Argument { spec=NoArgs ; converter=fun () -> () } let command ?group ~desc options params handler = Command { params ; options ; handler ; desc ; group ; conv = (fun x -> x) } (* Param combinators *) let string ~name ~desc next = param ~name ~desc { converter=(fun _ s -> return s) ; autocomplete=None } next let string_contains ~needle ~haystack = try Some (Re.Str.search_forward (Re.Str.regexp_string needle) haystack 0) with Not_found -> None let rec search_params_prefix : type a arg. string -> (a, arg) params -> bool = fun prefix -> function | Prefix (keyword, next) -> begin match string_contains ~needle:prefix ~haystack:keyword with | None -> search_params_prefix prefix next | Some _ -> true end | Param (_, _, _, next) -> search_params_prefix prefix next | Stop -> false | Seq _ -> false let search_command keyword (Command { params ; _ }) = search_params_prefix keyword params (* Command execution *) let exec (type ctx) (Command { options = (Argument { converter ; spec = options_spec }) ; params = spec ; handler ; conv ; _ } as command) (ctx : ctx) params args_dict = let rec exec : type ctx a. int -> ctx -> (a, ctx) params -> a -> string list -> unit tzresult Lwt.t = fun i ctx spec cb params -> match spec, params with | Stop, _ -> cb ctx | Seq (_, _, { converter ; _ }), seq -> let rec do_seq i acc = function | [] -> return (List.rev acc) | p :: rest -> Lwt.catch (fun () -> converter ctx p) (function | Failure msg -> Error_monad.failwith "%s" msg | exn -> fail (Exn exn)) |> trace (Bad_argument (i, p)) >>=? fun v -> do_seq (succ i) (v :: acc) rest in do_seq i [] seq >>=? fun parsed -> cb parsed ctx | Prefix (n, next), p :: rest when n = p -> exec (succ i) ctx next cb rest | Param (_, _, { converter ; _ }, next), p :: rest -> Lwt.catch (fun () -> converter ctx p) (function | Failure msg -> Error_monad.failwith "%s" msg | exn -> fail (Exn exn)) |> trace (Bad_argument (i, p)) >>=? fun v -> exec (succ i) ctx next (cb v) rest | _ -> raise (Failure ("cli_entries internal error: exec no case matched")) in let ctx = conv ctx in parse_args ~command options_spec args_dict ctx >>=? fun parsed_options -> exec 1 ctx spec (handler (converter parsed_options)) params (* Command dispatch tree *) type 'arg level = { stop : ('arg) command option ; prefix : (string * 'arg tree) list } and 'arg param_level = { stop : 'arg command option ; autocomplete : ('arg -> string list tzresult Lwt.t) option ; tree : 'arg tree } and 'ctx tree = | TPrefix : 'ctx level -> 'ctx tree | TParam : 'ctx param_level -> 'ctx tree | TStop : 'ctx command -> 'ctx tree | TSeq : 'ctx command * ('ctx -> string list tzresult Lwt.t) option -> 'ctx tree | TEmpty : 'ctx tree let has_options : type ctx. ctx command -> bool = fun (Command { options = Argument { spec ; _ } ; _ }) -> let args_help : type a ctx. (a, ctx) args -> bool = function | NoArgs -> false | AddArg (_, _) -> true in args_help spec let insert_in_dispatch_tree : type ctx. ctx tree -> ctx command -> ctx tree = fun root (Command { params ; conv ; _ } as command) -> let access_autocomplete : type p ctx. (p, ctx) parameter -> (ctx -> string list tzresult Lwt.t) option = fun { autocomplete ; _ } -> autocomplete in let rec insert_tree : type a ictx. (ctx -> ictx) -> ctx tree -> (a, ictx) params -> ctx tree = fun conv t c -> let insert_tree t c = insert_tree conv t c in match t, c with | TEmpty, Stop -> TStop command | TEmpty, Seq (_, _, { autocomplete ; _ }) -> TSeq (command, Option.map autocomplete ~f:(fun a c -> a (conv c))) | TEmpty, Param (_, _, param, next) -> let autocomplete = access_autocomplete param in let autocomplete = Option.map autocomplete ~f:(fun a c -> a (conv c)) in TParam { tree = insert_tree TEmpty next ; stop = None ; autocomplete} | TEmpty, Prefix (n, next) -> TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] } | TStop cmd, Param (_, _, param, next) -> let autocomplete = access_autocomplete param in let autocomplete = Option.map autocomplete ~f:(fun a c -> a (conv c)) in if not (has_options cmd) then TParam { tree = insert_tree TEmpty next ; stop = Some cmd ; autocomplete } else raise (Failure "Command cannot have both prefix and options") | TStop cmd, Prefix (n, next) -> TPrefix { stop = Some cmd ; prefix = [ (n, insert_tree TEmpty next) ] } | TParam t, Param (_, _, _, next) -> TParam { t with tree = insert_tree t.tree next } | TPrefix ({ prefix ; _ } as l), Prefix (n, next) -> let rec insert_prefix = function | [] -> [ (n, insert_tree TEmpty next) ] | (n', t) :: rest when n = n' -> (n, insert_tree t next) :: rest | item :: rest -> item :: insert_prefix rest in TPrefix { l with prefix = insert_prefix prefix } | TPrefix ({ stop = None ; _ } as l), Stop -> TPrefix { l with stop = Some command } | TParam ({ stop = None ; _ } as l), Stop -> TParam { l with stop = Some command } | _, _ -> Pervasives.failwith "Clic.Command_tree.insert: conflicting commands" in insert_tree conv root params let make_dispatch_tree commands = List.fold_left insert_in_dispatch_tree TEmpty commands let rec gather_commands ?(acc=[]) tree = match tree with | TEmpty -> acc | TSeq (c, _) | TStop c -> c :: acc | TPrefix { stop ; prefix } -> gather_assoc ~acc:(match stop with | None -> acc | Some c -> c :: acc) prefix | TParam { tree ; stop ; _ } -> gather_commands tree ~acc:(match stop with | None -> acc | Some c -> c :: acc) and gather_assoc ?(acc=[]) trees = List.fold_left (fun acc (_, tree) -> gather_commands tree ~acc) acc trees let find_command tree initial_arguments = let rec traverse tree arguments acc = match tree, arguments with | (TStop _ | TSeq _ | TPrefix { stop = Some _ ; _ } | TParam { stop = Some _ ; _}), ("-h" | "--help") :: _ -> begin match gather_commands tree with | [] -> assert false | [ command ] -> fail (Help (Some command)) | more -> fail (Unterminated_command (initial_arguments, more)) end | TStop c, [] -> return (c, empty_args_dict, initial_arguments) | TStop (Command { options = Argument { spec ; _ } ; _ } as command), remaining -> make_args_dict_filter ~command spec remaining >>=? fun (args_dict, unparsed) -> begin match unparsed with | [] -> return (command, args_dict, initial_arguments) | hd :: _ -> if String.length hd > 0 && String.get hd 0 = '-' then fail (Unknown_option (hd, Some command)) else fail (Extra_arguments (unparsed, command)) end | TSeq (Command { options = Argument { spec ; _ } ; _ } as command, _), remaining -> if List.exists (function "-h" | "--help" -> true | _ -> false) remaining then fail (Help (Some command)) else make_args_dict_filter ~command spec remaining >>|? fun (dict, remaining) -> (command, dict, List.rev_append acc remaining) | TPrefix { stop = Some cmd ; _ }, [] -> return (cmd, empty_args_dict, initial_arguments) | TPrefix { stop = None ; prefix }, ([] | ("-h" | "--help") :: _) -> fail (Unterminated_command (initial_arguments, gather_assoc prefix)) | TPrefix { prefix ; _ }, hd_arg :: tl -> begin try return (List.assoc hd_arg prefix) with Not_found -> fail (Command_not_found (List.rev acc, gather_assoc prefix)) end >>=? fun tree' -> traverse tree' tl (hd_arg :: acc) | TParam { stop = None ; _ }, ([] | ("-h" | "--help") :: _) -> fail (Unterminated_command (initial_arguments, gather_commands tree)) | TParam { stop = Some c ; _ }, [] -> return (c, empty_args_dict, initial_arguments) | TParam { tree ; _ }, parameter :: arguments' -> traverse tree arguments' (parameter :: acc) | TEmpty, _ -> fail (Command_not_found (List.rev acc, [])) in traverse tree initial_arguments [] let get_arg_label (type a) (arg : (a, _) arg) = match arg with | Arg { label ; _ } -> label | DefArg { label ; _ } -> label | Switch { label ; _ } -> label | Constant _ -> assert false let get_arg : type a ctx. (a, ctx) arg -> string list = fun arg -> let { long ; short } = get_arg_label arg in ("--" ^ long) :: match short with None -> [] | Some c -> [ "-" ^ String.make 1 c ] let rec list_args : type arg ctx. (arg, ctx) args -> string list = function | NoArgs -> [] | AddArg (Constant _, args) -> list_args args | AddArg (arg, args) -> get_arg arg @ list_args args let complete_func autocomplete cctxt = match autocomplete with | None -> return_nil | Some autocomplete -> autocomplete cctxt let list_command_args (Command { options = Argument { spec ; _ } ; _ }) = list_args spec let complete_arg : type a ctx. ctx -> (a, ctx) arg -> string list tzresult Lwt.t = fun ctx -> function | Arg { kind = { autocomplete ; _ } ; _ } -> complete_func autocomplete ctx | DefArg { kind = { autocomplete ; _ } ; _ } -> complete_func autocomplete ctx | Switch _ -> return_nil | Constant _ -> return_nil let rec remaining_spec : type a ctx. TzString.Set.t -> (a, ctx) args -> string list = fun seen -> function | NoArgs -> [] | AddArg (Constant _, rest) -> remaining_spec seen rest | AddArg (arg, rest) -> let { long ; _ } = get_arg_label arg in if TzString.Set.mem long seen then remaining_spec seen rest else get_arg arg @ remaining_spec seen rest let complete_options (type ctx) continuation args args_spec ind (ctx : ctx) = let arities = make_arities_dict args_spec TzString.Map.empty in let rec complete_spec : type a. string -> (a, ctx) args -> string list tzresult Lwt.t = fun name -> function | NoArgs -> return_nil | AddArg (Constant _, rest) -> complete_spec name rest | AddArg (arg, rest) -> if (get_arg_label arg).long = name then complete_arg ctx arg else complete_spec name rest in let rec help args ind seen = match args with | _ when ind = 0 -> continuation args 0 >>|? fun cont_args -> cont_args @ remaining_spec seen args_spec | [] -> Pervasives.failwith "cli_entries internal autocomplete error" | arg :: tl -> if TzString.Map.mem arg arities then let arity, long = TzString.Map.find arg arities in let seen = TzString.Set.add long seen in match arity, tl with | 0, args when ind = 0 -> continuation args 0 >>|? fun cont_args -> remaining_spec seen args_spec @ cont_args | 0, args -> help args (ind - 1) seen | 1, _ when ind = 1 -> complete_spec arg args_spec | 1, _ :: tl -> help tl (ind - 2) seen | _ -> Pervasives.failwith "cli_entries internal error, invalid arity" else continuation args ind in help args ind TzString.Set.empty let complete_next_tree cctxt = function | TPrefix { stop; prefix } -> return ((match stop with | None -> [] | Some command -> list_command_args command) @ (List.map fst prefix)) | TSeq (command, autocomplete) -> complete_func autocomplete cctxt >>|? fun completions -> completions @ (list_command_args command) | TParam { autocomplete ; _ } -> complete_func autocomplete cctxt | TStop command -> return (list_command_args command) | TEmpty -> return_nil let complete_tree cctxt tree index args = let rec help tree args ind = if ind = 0 then complete_next_tree cctxt tree else match tree, args with | TSeq _, _ -> complete_next_tree cctxt tree | TPrefix { prefix ; _ }, hd :: tl -> begin try help (List.assoc hd prefix) tl (ind - 1) with Not_found -> return_nil end | TParam { tree ; _ }, _ :: tl -> help tree tl (ind - 1) | TStop Command { options = Argument { spec ; _ } ; conv ;_ }, args -> complete_options (fun _ _ -> return_nil) args spec ind (conv cctxt) | (TParam _ | TPrefix _), [] | TEmpty, _ -> return_nil in help tree args index let autocompletion ~script ~cur_arg ~prev_arg ~args ~global_options commands cctxt = let tree = make_dispatch_tree commands in let rec ind n = function | [] -> None | hd :: tl -> if hd = prev_arg then Some (Option.unopt ~default:(n + 1) (ind (n + 1) tl)) else (ind (n + 1) tl) in begin if prev_arg = script then complete_next_tree cctxt tree >>|? fun command_completions -> begin let (Argument { spec ; _ }) = global_options in list_args spec @ command_completions end else match ind 0 args with | None -> return_nil | Some index -> begin let Argument { spec ; _ } = global_options in complete_options (fun args ind -> complete_tree cctxt tree ind args) args spec index cctxt end end >>|? fun completions -> List.filter (fun completion -> Re.Str.(string_match (regexp_string cur_arg) completion 0)) completions let parse_global_options global_options ctx args = let Argument { spec ; converter } = global_options in make_args_dict_consume spec args >>=? fun (dict, remaining) -> parse_args spec dict ctx >>=? fun nested -> return (converter nested, remaining) let dispatch commands ctx args = let tree = make_dispatch_tree commands in match args with | [] | [ "-h" | "--help" ] -> fail (Help None) | _ -> find_command tree args >>=? fun (command, args_dict, filtered_args) -> exec command ctx filtered_args args_dict type error += No_manual_entry of string list let manual_group = { name = "man" ; title = "Access the documentation" } let add_manual ~executable_name ~global_options format ppf commands = let rec with_manual = lazy (commands @ [ command ~group:manual_group ~desc:"Print documentation of commands.\n\ Add search keywords to narrow list.\n\ Will display only the commands by default, \ unless [-verbosity <2|3>] is passed or the list \ of matching commands if less than 3." (args2 (arg ~doc:"level of details\n\ 0. Only shows command mnemonics, without documentation.\n\ 1. Shows command mnemonics with short descriptions.\n\ 2. Show commands and arguments with short descriptions\n\ 3. Show everything" ~long:"verbosity" ~short:'v' ~placeholder:"0|1|2|3" (parameter ~autocomplete: (fun _ -> return [ "0" ; "1" ; "2" ; "3" ]) (fun _ arg -> match arg with | "0" -> return Terse | "1" -> return Short | "2" -> return Details | "3" -> return Full | _ -> failwith "Level of details out of range"))) (default_arg ~doc:"the manual's output format" ~placeholder: "plain|colors|html" ~long: "format" ~default: (match format with | Ansi -> "colors" | Plain -> "plain" | Html -> "html") (parameter ~autocomplete: (fun _ -> return [ "colors" ; "plain" ; "html" ]) (fun _ arg -> match arg with | "colors" -> return Ansi | "plain" -> return Plain | "html" -> return Html | _ -> failwith "Unknown manual format")))) (prefix "man" (seq_of_param (string ~name:"keyword" ~desc:"keyword to search for\n\ If several are given they must all appear in the command."))) (fun (verbosity, format) keywords _ -> let commands = List.fold_left (fun commands keyword -> List.filter (search_command keyword) commands) (Lazy.force with_manual) keywords in let verbosity = match verbosity with | Some verbosity -> verbosity | None when List.length commands <= 3 -> Full | None -> Short in match commands with | [] -> fail (No_manual_entry keywords) | _ -> let state = setup_formatter ppf format verbosity in let commands = List.map (fun c -> Ex c) commands in usage_internal ppf ~executable_name ~global_options ~highlights:keywords commands ; restore_formatter ppf state ; return_unit) ]) in Lazy.force with_manual let pp_cli_errors ppf ~executable_name ~global_options ~default errs = let pp_one = function | Bad_argument (i, v) -> Format.fprintf ppf "Erroneous command line argument %d (%s)." i v ; Some [] | Option_expected_argument (arg, command) -> Format.fprintf ppf "Command line option @{<opt>%s@} expects an argument." arg ; Some (Option.unopt_map ~f:(fun command -> [ Ex command ]) ~default:[] command) | Bad_option_argument (arg, command) -> Format.fprintf ppf "Wrong value for command line option @{<opt>%s@}." arg ; Some (Option.unopt_map ~f:(fun command -> [ Ex command ]) ~default:[] command) | Multiple_occurences (arg, command) -> Format.fprintf ppf "Command line option @{<opt>%s@} appears multiple times." arg ; Some (Option.unopt_map ~f:(fun command -> [ Ex command ]) ~default:[] command) | No_manual_entry [ keyword ] -> Format.fprintf ppf "No manual entry that match @{<hilight>%s@}." keyword ; Some [] | No_manual_entry (keyword :: keywords) -> Format.fprintf ppf "No manual entry that match %a and @{<hilight>%s@}." (Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ") (fun ppf keyword -> Format.fprintf ppf "@{<hilight>%s@}" keyword)) keywords keyword ; Some [] | Unknown_option (option, command) -> Format.fprintf ppf "Unexpected command line option @{<opt>%s@}." option ; Some (Option.unopt_map ~f:(fun command -> [ Ex command ]) ~default:[] command) | Extra_arguments (extra, command) -> Format.fprintf ppf "Extra command line arguments:@, @[<h>%a@]." (Format.pp_print_list (fun ppf -> Format.fprintf ppf "%s")) extra ; Some [ Ex command ] | Unterminated_command (_, commands) -> Format.fprintf ppf "@[<v 2>Unterminated command, here are possible completions.@,%a@]" (Format.pp_print_list (fun ppf (Command { params ; options = Argument { spec ; _ } ; _ }) -> print_commandline ppf ([], spec, params))) commands ; Some (List.map (fun c -> Ex c) commands) | Command_not_found ([], _all_commands) -> Format.fprintf ppf "@[<v 0>Unrecognized command.@,\ Try using the @{<kwd>man@} command to get more information.@]" ; Some [] | Command_not_found (_, commands) -> Format.fprintf ppf "@[<v 0>Unrecognized command.@,\ Did you mean one of the following?@, @[<v 0>%a@]@]" (Format.pp_print_list (fun ppf (Command { params ; options = Argument { spec ; _ } ; _ }) -> print_commandline ppf ([], spec, params))) commands ; Some (List.map (fun c -> Ex c) commands) | err -> default ppf err ; None in let rec pp acc errs = let return command = match command, acc with | None, _ -> acc | Some command, Some commands -> Some (command @ commands) | Some command, None -> Some command in match errs with | [] -> None | [ last ] -> return (pp_one last) | err :: errs -> let acc = return (pp_one err) in Format.fprintf ppf "@," ; pp acc errs in Format.fprintf ppf "@[<v 2>@{<error>@{<title>Error@}@}@," ; match pp None errs with | None -> Format.fprintf ppf "@]@\n" | Some commands -> Format.fprintf ppf "@]@\n@\n@[<v 0>%a@]" (fun ppf commands -> usage_internal ppf ~executable_name ~global_options commands) commands let usage ppf ~executable_name ~global_options commands = usage_internal ppf ~executable_name ~global_options (List.map (fun c -> Ex c) commands) let map_command f (Command c) = (Command { c with conv = (fun x -> c.conv (f x)) })