diff --git a/src/bin_client/bash-completion.sh b/src/bin_client/bash-completion.sh index c772475d2..52ec6ad2c 100755 --- a/src/bin_client/bash-completion.sh +++ b/src/bin_client/bash-completion.sh @@ -8,7 +8,7 @@ _tezos-client_complete() # Tezos script script=${COMP_WORDS[0]} - reply=$($script bash_autocomplete "$prev_word" "$cur_word" ${COMP_WORDS[@]}) + reply=$($script bash_autocomplete "$prev_word" "$cur_word" ${COMP_WORDS[@]} 2>/dev/null) COMPREPLY=($(compgen -W "$reply" -- $cur_word)) diff --git a/src/bin_client/main_lib.ml b/src/bin_client/main_lib.ml index 4794ce103..22b058f54 100644 --- a/src/bin_client/main_lib.ml +++ b/src/bin_client/main_lib.ml @@ -23,7 +23,7 @@ let get_commands_for_version ctxt block protocol = Format.eprintf "@[Warning:@,\ The protocol provided via `-protocol` (%a)@,\ - is not the one retrieved from the node (%a).@." + is not the one retrieved from the node (%a).@]@\n@." Protocol_hash.pp_short given_version Protocol_hash.pp_short version ; return (Some version, Client_commands.commands_for_version given_version) @@ -33,7 +33,8 @@ let get_commands_for_version ctxt block protocol = match protocol with | None -> begin Format.eprintf - "@[Ignored error:@,Failed to acquire the protocol version from the node@,%a@." + "@[@{@{Warning@}@}@,\ + Failed to acquire the protocol version from the node@,%a@]@\n@." (Format.pp_print_list pp) errs ; return (None, []) end @@ -43,10 +44,25 @@ let get_commands_for_version ctxt block protocol = (* Main (lwt) entry *) let main ?only_commands () = + let executable_name = Filename.basename Sys.executable_name in + let global_options = Client_config.global_options () in + let original_args, autocomplete = + (* for shell aliases *) + let rec move_autocomplete_token_upfront acc = function + | "bash_autocomplete" :: prev_arg :: cur_arg :: script :: args -> + let args = List.rev acc @ args in + args, Some (prev_arg, cur_arg, script) + | x :: rest -> move_autocomplete_token_upfront (x :: acc) rest + | [] -> List.rev acc, None in + match Array.to_list Sys.argv with + | _ :: args -> move_autocomplete_token_upfront [] args + | [] -> [], None in Random.self_init () ; - Lwt.catch begin fun () -> - let original_args = List.tl (Array.to_list Sys.argv) in - begin + ignore Cli_entries.(setup_formatter Format.std_formatter + (if Unix.isatty Unix.stdout then Ansi else Plain) Short) ; + ignore Cli_entries.(setup_formatter Format.err_formatter + (if Unix.isatty Unix.stderr then Ansi else Plain) Short) ; + Lwt.catch begin fun () -> begin Client_config.parse_config_args (cctxt ~base_dir:Client_commands.default_base_dir ~block:Client_commands.default_block @@ -75,6 +91,13 @@ let main ?only_commands () = | Some commands -> return (config_commands @ commands) end >>=? fun commands -> + let commands = + Cli_entries.add_manual + ~executable_name + ~global_options + (if Unix.isatty Unix.stdout then Cli_entries.Ansi else Cli_entries.Plain) + Format.std_formatter + commands in let rpc_config = if parsed_args.print_timings then { rpc_config with @@ -85,35 +108,45 @@ let main ?only_commands () = in let client_config = cctxt ~block:parsed_args.block ~base_dir:parsed_config_file.base_dir rpc_config in - (Cli_entries.dispatch - ~global_options:(Client_config.global_options ()) - commands - client_config - remaining) end >>= - Cli_entries.handle_cli_errors - ~stdout:Format.std_formatter - ~stderr:Format.err_formatter - ~global_options:(Client_config.global_options ()) - >>= function - | Ok i -> - Lwt.return i + begin match autocomplete with + | Some (prev_arg, cur_arg, script) -> + Cli_entries.autocompletion + ~script ~cur_arg ~prev_arg ~args:original_args ~global_options + commands client_config >>=? fun completions -> + List.iter print_endline completions ; + return () + | None -> + Cli_entries.dispatch commands client_config remaining + end + end >>= function + | Ok () -> + Lwt.return 0 + | Error [ Cli_entries.Help command ] -> + Cli_entries.usage + Format.std_formatter + ~executable_name + ~global_options + (match command with None -> [] | Some c -> [ c ]) ; + Lwt.return 0 | Error errs -> - Format.eprintf "@[<v 2>Fatal error:@,%a@." - (Format.pp_print_list Error_monad.pp) errs ; + Cli_entries.pp_cli_errors + Format.err_formatter + ~executable_name + ~global_options + ~default:Error_monad.pp + errs ; Lwt.return 1 end begin function - | Arg.Help help -> - Format.printf "%s%!" help ; - Lwt.return 0 - | Client_commands.Version_not_found -> - Format.eprintf "Unknown protocol version.@." ; + | Client_commands.Version_not_found -> + Format.eprintf "@{<error>@{<title>Fatal error@}@} unknown protocol version." ; Lwt.return 1 | Failure message -> - Format.eprintf - "Fatal error: %s@." message ; + Format.eprintf "@{<error>@{<title>Fatal error@}@} %s." message ; Lwt.return 1 | exn -> - Format.printf "Fatal internal error: %s@." - (Printexc.to_string exn) ; + Format.printf "@{<error>@{<title>Fatal error@}@} %s." (Printexc.to_string exn) ; Lwt.return 1 - end + end >>= fun retcode -> + Format.fprintf Format.std_formatter "@." ; + Format.fprintf Format.err_formatter "@." ; + Lwt.return retcode diff --git a/src/lib_base/cli_entries.ml b/src/lib_base/cli_entries.ml index 316fb721a..0d2561654 100644 --- a/src/lib_base/cli_entries.ml +++ b/src/lib_base/cli_entries.ml @@ -7,15 +7,8 @@ (* *) (**************************************************************************) -(* Tezos Command line interface - Command Line Parsing *) - open Error_monad -(* User catchable exceptions *) -type error += Bad_argument of int * string -type error += Option_expected_argument of string -type error += Unknown_option of string - type ('p, 'ctx) parameter = { converter: ('ctx -> string -> 'p tzresult Lwt.t) ; autocomplete: ('ctx -> string list tzresult Lwt.t) option } @@ -38,514 +31,53 @@ type ('a, 'ctx) arg = parameter : string } -> (bool, 'ctx) arg -let arg ~doc ~parameter ~placeholder kind = - Arg { doc ; - parameter ; - placeholder ; - kind } - -let default_arg ~doc ~parameter ~placeholder ~default kind = - DefArg { doc ; - placeholder ; - parameter ; - kind ; - default } - -let switch ~doc ~parameter = - Switch { doc ; parameter } - type ('a, 'arg) args = | NoArgs : (unit, 'args) args | AddArg : ('a, 'args) arg * ('b, 'args) args -> ('a * 'b, 'args) args -let parse_arg : - type a ctx. (a, ctx) arg -> string option TzString.Map.t -> ctx -> a tzresult Lwt.t = - fun spec args_dict ctx -> - match spec with - | Arg { parameter ; kind = { converter ; _ } ; _ } -> - begin - try - begin - match TzString.Map.find parameter args_dict with - | None -> return None - | Some s -> - (converter ctx s) >>|? fun x -> - Some x - end - with Not_found -> - return None - end - | DefArg { parameter ; 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." - parameter) end >>=? fun default -> - begin try - match TzString.Map.find parameter args_dict with - | None -> return default - | Some s -> converter ctx s - with Not_found -> return default - end - | Switch { parameter ; _ } -> - return (TzString.Map.mem parameter args_dict) - -(* Argument parsing *) -let rec parse_args : - type a ctx. (a, ctx) args -> string option TzString.Map.t -> ctx -> a tzresult Lwt.t = - fun spec args_dict ctx -> - match spec with - | NoArgs -> return () - | AddArg (arg, rest) -> - parse_arg arg args_dict ctx >>=? fun arg -> - parse_args rest args_dict ctx >>|? fun rest -> - (arg, rest) - -let empty_args_dict = TzString.Map.empty - -let rec make_arities_dict : - type a b. int TzString.Map.t -> (a, b) args -> int TzString.Map.t = - fun acc -> function - | NoArgs -> acc - | AddArg (arg, rest) -> - let recur parameter num = - make_arities_dict (TzString.Map.add parameter num acc) rest in - begin - match arg with - | Arg { parameter ; _ } -> recur parameter 1 - | DefArg { parameter ; _ } -> recur parameter 1 - | Switch { parameter ; _ } -> recur parameter 0 - end - -let check_help_flag error = function - | ("-help" | "--help") :: _ -> fail error - | _ -> return () - -(* ignore_autocomplete is a hack to have the initial arguments get parsed - even if autocomplete command is running *) -let make_args_dict_consume help_flag ignore_autocomplete spec args = - let rec make_args_dict completing arities acc args = - check_help_flag help_flag args >>=? fun () -> - match args with - | [] -> return (acc, []) - | "bash_autocomplete" :: prev_arg :: cur_arg :: script :: remaining_args - when ignore_autocomplete -> - make_args_dict true arities acc remaining_args >>=? fun (dict, _) -> - return (dict, "bash_autocomplete" :: prev_arg :: cur_arg :: script :: remaining_args) - | arg :: tl -> - if TzString.Map.mem arg arities - then let arity = TzString.Map.find arg arities in - check_help_flag help_flag tl >>=? fun () -> - match arity, tl with - | 0, tl' -> make_args_dict completing arities (TzString.Map.add arg None acc) tl' - | 1, value :: tl' -> - make_args_dict completing arities (TzString.Map.add arg (Some value) acc) tl' - | 1, [] when completing -> - return (acc, []) - | 1, [] -> - fail (Option_expected_argument arg) - | _, _ -> - raise (Failure "cli_entries: Arguments with arity not equal to 1 or 0 not supported") - else return (acc, args) - in make_args_dict false (make_arities_dict TzString.Map.empty spec) TzString.Map.empty args - -let make_args_dict_filter help_flag spec args = - let rec make_args_dict arities (dict, other_args) args = - check_help_flag help_flag args >>=? fun () -> - match args with - | [] -> return (dict, other_args) - | arg :: tl -> - if TzString.Map.mem arg arities - then let arity = TzString.Map.find arg arities in - check_help_flag help_flag tl >>=? fun () -> - match arity, tl with - | 0, tl -> make_args_dict arities (TzString.Map.add arg None dict, other_args) tl - | 1, value :: tl' -> make_args_dict arities (TzString.Map.add arg (Some value) dict, other_args) tl' - | 1, [] -> fail (Option_expected_argument arg) - | _, _ -> - 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 TzString.Map.empty spec) - (TzString.Map.empty, []) - args >>|? fun (dict, remaining) -> - (dict, List.rev remaining) - -let make_args_dict help_handler spec args = - make_args_dict_consume help_handler false spec args >>=? fun (args, remaining) -> - match remaining with - | [] -> return args - | hd :: _ -> fail (Unknown_option hd) +(* 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 -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 } - -(* A simple structure for command interpreters. - This is more generic than the exported one, see end of file. *) -type ('a, 'ctx, 'ret) params = - | Prefix : string * ('a, 'ctx, 'ret) params -> - ('a, 'ctx, 'ret) params - | Param : string * string * - ('p, 'ctx) parameter * - ('a, 'ctx, 'ret) params -> - ('p -> 'a, 'ctx, 'ret) params - | Stop : - ('ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params - | Seq : string * string * - ('p, 'ctx) parameter -> - ('p list -> 'ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params - (* A command group *) type group = { name : string ; title : string } (* A command wraps a callback with its type and info *) -type ('arg, 'ret) command = +type 'arg command = | Command - : { params : ('a, 'iarg, 'ret) params ; + : { params : ('a, 'iarg) params ; options : ('b, 'iarg) options ; handler : 'b -> 'a ; desc : string ; group : group option ; - conv : 'arg -> 'iarg } -> ('arg, 'ret) command + conv : 'arg -> 'iarg } + -> 'arg command -type format = [ `Plain | `Ansi | `Html ] - -type error += Extra_arguments : string list * (_, _) command -> error -type error += Not_enough_args : string list * ('a, 'b) command list -> error -type error += Command_not_found : string list * ('a, 'b) command list -> error -type error += Help_flag : ('a, 'b) command list -> error (* when -help appears in input *) -type error += Help_cmd : string list * ('a, 'b) command list * format * [ `Terse | `Short | `Args | `Full ] -> error (* ./tezos-client help *) -type error += Bare_help : error (* ./tezos-client or ./tezos-client -help *) -type error += Autocomplete_command : string list -> error - -let parse_initial_options : - type a ctx. (a, ctx) options -> ctx -> string list -> (a * string list) tzresult Lwt.t = - fun (Argument { spec ; converter }) ctx args -> - make_args_dict_consume Bare_help true spec args >>=? fun (dict, remaining) -> - parse_args spec dict ctx >>|? fun nested -> - (converter nested, remaining) - -(* 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 "Cli_entries.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 - -(* Help commands *) -let help_group = - { name = "man" ; - title = "Access the documentation" } - -let string_contains ~needle ~haystack = - try - Some Re_str.(search_forward (regexp_string needle) haystack 0) - with Not_found -> - None - -let rec search_params_prefix : type a arg ret. string -> (a, arg, ret) 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 - -let rec help_commands commands = - [ command - ~group:help_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" - ~parameter:"-verbosity" - ~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 `Args - | "3" -> return `Full - | _ -> failwith "Level of details out of range"))) - (default_arg - ~doc:"the manual's output format" - ~placeholder: "plain|colors|html" - ~parameter: "-format" - ~default: (if Unix.isatty Unix.stdout then "colors" else "plain") - (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) - (help_commands [] @ commands) - keywords in - let verbosity = match verbosity with - | Some verbosity -> verbosity - | None when List.length commands <= 3 -> `Full - | None -> `Short in - fail (Help_cmd (keywords, commands, format, verbosity))) ] - -(* Command execution *) - -let exec - (type ctx) - (Command { options = (Argument { converter ; spec = options_spec }) ; - params = spec ; - handler ; - conv ; - _ }) - (ctx : ctx) params args_dict = - let rec exec - : type a ctx ret. int -> ctx -> (a, ctx, ret) params -> a -> string list -> ret 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 options_spec args_dict ctx >>=? fun parsed_options -> - exec 1 ctx spec (handler (converter parsed_options)) params - -(* Command dispatch tree *) -type ('arg, 'ret) level = - { stop : ('arg, 'ret) command option ; - prefix : (string * ('arg, 'ret) tree) list } -and ('arg, 'ret) param_level = - { stop : ('arg, 'ret) command option ; - autocomplete : ('arg -> string list tzresult Lwt.t) option ; - tree : ('arg, 'ret) tree } -and ('ctx, 'ret) tree = - | TPrefix : ('ctx, 'ret) level -> ('ctx, 'ret) tree - | TParam : ('ctx, 'ret) param_level -> ('ctx, 'ret) tree - | TStop : ('ctx, 'ret) command -> ('ctx, 'ret) tree - | TSeq : ('ctx, 'ret) command * ('ctx -> string list tzresult Lwt.t) option -> ('ctx, 'ret) tree - | TEmpty : ('ctx, 'ret) tree - -let has_options : type ret ctx. (ctx, ret) command -> bool = - fun (Command { options = Argument { spec ; _ } ; _ }) -> - let args_help : type a. (a, _) args -> bool = function - | NoArgs -> false - | AddArg (_, _) -> true - in args_help spec - -let insert_in_dispatch_tree : - type ctx ret. (ctx, ret) tree -> (ctx, ret) command -> (ctx, ret) 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, ret) tree -> (a, ictx, ret) params -> (ctx, ret) 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 - "Cli_entries.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 help tree arguments acc = - match tree, arguments with - | (TStop _ | TSeq _ - | TPrefix { stop = Some _ ; _ } - | TParam { stop = Some _ ; _}), ("-help" | "--help") :: _ -> - fail (Help_flag ( gather_commands tree)) - | TStop c, [] -> return (c, empty_args_dict, initial_arguments) - | TStop (Command { options = Argument { spec ; _ } ; _ } as c), args -> - if not (has_options c) - then fail (Extra_arguments (List.rev acc, c)) - else make_args_dict (Help_flag [c]) spec args >>=? fun args_dict -> - return (c, args_dict, initial_arguments) - | TSeq (Command { options = Argument { spec ; _ } ; _ } as c, _), remaining -> - if List.exists (function "-help" | "--help" -> true | _ -> false) remaining then - fail (Help_flag ( gather_commands tree)) - else - make_args_dict_filter (Help_flag [c]) spec remaining >>|? fun (dict, remaining) -> - (c, dict, List.rev_append acc remaining) - | TPrefix { stop = Some cmd ; _ }, [] -> - return (cmd, empty_args_dict, initial_arguments) - | TPrefix { stop = None ; prefix }, ([] | ("-help" | "--help") :: _) -> - fail (Not_enough_args (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' -> - help tree' tl (hd_arg :: acc) - | TParam { stop = None ; _ }, ([] | ("-help" | "--help") :: _) -> - fail (Not_enough_args (initial_arguments, gather_commands tree)) - | TParam { stop = Some c ; _ }, [] -> - return (c, empty_args_dict, initial_arguments) - | TParam { tree ; _ }, parameter :: arguments' -> - help tree arguments' (parameter :: acc) - | TEmpty, _ -> - fail (Command_not_found (List.rev acc, [])) - in help tree initial_arguments [] +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 -> error +type error += Option_expected_argument : string * 'ctx command option -> error +type error += Bad_option_argument : string * 'ctx command option -> error +type error += Extra_arguments : string list * 'ctx command -> error let trim s = (* config-file wokaround *) TzString.split '\n' s |> @@ -630,7 +162,7 @@ let print_highlight highlight_strings formatter str = let print_commandline ppf (highlights, options, args) = let rec print - : type a ctx ret. Format.formatter -> (a, ctx, ret) params -> unit = + : 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) -> @@ -649,7 +181,7 @@ let print_commandline ppf (highlights, options, args) = Format.fprintf ppf "@{<commandline>%a@}" print args let rec print_params_detailed - : type a b ctx ret. (b, ctx) args -> Format.formatter -> (a, ctx, ret) params -> unit + : 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, _) -> @@ -673,9 +205,9 @@ let rec print_params_detailed n print_desc (trim desc) (print_params_detailed spec) next let contains_params_args : - type a b arg ctx. (a, arg, ctx) params -> (b, _) args -> bool + type arg ctx. (arg, ctx) params -> (_, ctx) args -> bool = fun params args -> - let rec help : (a, arg, ctx) params -> bool = function + let rec help : (arg, ctx) params -> bool = function | Stop -> has_args args | Seq (_, _, _) -> true | Prefix (_, next) -> help next @@ -683,16 +215,16 @@ let contains_params_args : in help params let print_command : - type ctx ret. + type ctx. ?prefix:(Format.formatter -> unit -> unit) -> - ?highlights:string list -> Format.formatter -> (ctx, ret) command -> 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 "@{<command>%a%a@{<short>@,@{<commanddoc>%a@{<args>@,%a@}@}@}@}" + Format.fprintf ppf "@{<command>%a%a@{<short>@,@{<commanddoc>%a@,%a@}@}@}" prefix () print_commandline (highlights, spec, params) print_desc desc @@ -703,10 +235,12 @@ let print_command : 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) (Command { group ; _ } as command) -> + (fun (grouped, ungrouped) (Ex (Command { group ; _ }) as command) -> match group with | None -> (grouped, command :: ungrouped) @@ -736,11 +270,12 @@ let print_group print_command ppf ({ title ; _ }, commands) = (Format.pp_print_list print_command) commands type formatter_state = - Format.formatter_out_functions * - Format.formatter_tag_functions * - bool + Format.formatter_out_functions * Format.formatter_tag_functions * bool -let setup_formatter ppf ~format ~verbosity = +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 (), @@ -757,23 +292,37 @@ let setup_formatter ppf ~format ~verbosity = out_newline = (fun () -> if not !skip then orig_out_functions.out_newline ()) ; out_flush = (fun () -> if not !skip then orig_out_functions.out_flush ()) } ; let levels = ref [] in - let setup_level level = - match verbosity, level with - | (`Full, (`Terse | `Short | `Args | `Full)) - | (`Args, (`Terse | `Short | `Args)) - | (`Short, (`Terse | `Short)) - | `Terse, `Terse -> Format.fprintf ppf "@<0>%s" "\255\255\255" - | _ -> Format.fprintf ppf "@<0>%s" "\000\000\000" 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 _ = + let pop_level () = match !levels with | _ :: level :: rest -> levels := level :: rest ; setup_level level | [ _ ] | [] -> Pervasives.failwith "Cli_entries: unclosed verbosity tag" in - push_level `Terse ; + 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 ("Cli_entries: 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 ("Cli_entries: invalid semantic tag <" ^ tag ^ ">") in match format with - | `Ansi -> + | Ansi -> let color_num = function | `Black -> None | `Red -> Some 1 @@ -793,44 +342,58 @@ let setup_formatter ppf ~format ~verbosity = with | [] -> () | l -> Format.fprintf ppf "@<0>%s" ("\027[" ^ String.concat ";" l ^ "m") in + let ansi_stack = ref [ (`White, `Black, 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 "Cli_entries: 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" -> Format.fprintf ppf "@<0>%a" ansi_format (`White, `Black, true, true) + | "title" -> push_ansi_format (None, None, true, true) | "commandline" -> Format.fprintf ppf "@[<hov 4>" | "commanddoc" -> Format.fprintf ppf " @[<v 0>" - | "opt" -> Format.fprintf ppf "@<0>%a" ansi_format (`Green, `Black, false, false) - | "arg" -> Format.fprintf ppf "@<0>%a<" ansi_format (`Yellow, `Black, false, false) - | "kwd" -> Format.fprintf ppf "@<0>%a" ansi_format (`White, `Black, false, true) - | "hilight" -> Format.fprintf ppf "@<0>%a" ansi_format (`Black, `Yellow, false, true) + | "opt" -> push_ansi_format (Some `Green, Some `Black, false, false) + | "arg" -> push_ansi_format (Some `Yellow, Some `Black, false, false) ; Format.fprintf ppf "<" + | "kwd" -> push_ansi_format (Some `White, Some `Black, false, true) + | "error" -> push_ansi_format (Some `Red, Some `Black, true, true) + | "warning" -> push_ansi_format (Some `Yellow, Some `Black, true, true) + | "hilight" -> push_ansi_format (Some `Black, Some `Yellow, false, true) | "list" -> Format.fprintf ppf " @[<v 0>" | "command" -> Format.fprintf ppf "@[<v 0>" - | "full" -> push_level `Full - | "args" -> push_level `Args - | "short" -> push_level `Short - | "terse" -> push_level `Terse | "document" -> Format.fprintf ppf "@[<v 0>" - | _ -> Pervasives.failwith "Cli_entries: invalid semantic tag" + | other -> push_level_tag other end ; print_close_tag = begin function - | "title" -> Format.fprintf ppf ":@<0>%s" "\027[0m" + | "title" -> Format.fprintf ppf ":" ; pop_ansi_format () | "commandline" -> Format.fprintf ppf "@]" | "commanddoc" -> Format.fprintf ppf "@]" - | "opt" -> Format.fprintf ppf "@<0>%s" "\027[0m" - | "arg" -> Format.fprintf ppf ">@<0>%s" "\027[0m" - | "kwd" -> Format.fprintf ppf "@<0>%s" "\027[0m" - | "hilight" -> Format.fprintf ppf "@<0>%s" "\027[0m" + | "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 "@]" - | "full" -> pop_level `Full - | "args" -> pop_level `Args - | "short" -> pop_level `Short - | "terse" -> pop_level `Terse | "document" -> Format.fprintf ppf "@]" - | _ -> Pervasives.failwith "Cli_entries: invalid semantic tag" + | other -> pop_level_tag other end } ; Format.pp_set_print_tags ppf true - | `Plain -> + | Plain -> Format.pp_set_formatter_tag_functions ppf { mark_open_tag = (fun _ -> "") ; mark_close_tag = (fun _ -> "") ; @@ -842,14 +405,12 @@ let setup_formatter ppf ~format ~verbosity = | "arg" -> Format.fprintf ppf "<" | "kwd" -> () | "hilight" -> () + | "error" -> () + | "warning" -> () | "list" -> Format.fprintf ppf " @[<v 0>" | "command" -> Format.fprintf ppf "@[<v 0>" - | "full" -> push_level `Full - | "args" -> push_level `Args - | "short" -> push_level `Short - | "terse" -> push_level `Terse | "document" -> Format.fprintf ppf "@[<v 0>" - | _ -> Pervasives.failwith "Cli_entries: invalid semantic tag" + | other -> push_level_tag other end ; print_close_tag = begin function | "title" -> Format.fprintf ppf ":" @@ -858,17 +419,15 @@ let setup_formatter ppf ~format ~verbosity = | "opt" -> () | "arg" -> Format.fprintf ppf ">" | "kwd" -> () + | "error" -> () + | "warning" -> () | "hilight" -> () | "command" | "list" -> Format.fprintf ppf "@]" - | "full" -> pop_level `Full - | "args" -> pop_level `Args - | "short" -> pop_level `Short - | "terse" -> pop_level `Terse | "document" -> Format.fprintf ppf "@]" - | _ -> Pervasives.failwith "Cli_entries: invalid semantic tag" + | other -> pop_level_tag other end } ; Format.pp_set_print_tags ppf true - | `Html -> + | Html -> Format.pp_set_formatter_tag_functions ppf { mark_open_tag = (fun _ -> "") ; mark_close_tag = (fun _ -> "") ; @@ -880,12 +439,10 @@ let setup_formatter ppf ~format ~verbosity = | "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" - | "full" -> push_level `Full - | "args" -> push_level `Args - | "short" -> push_level `Short - | "terse" -> push_level `Terse | "document" -> Format.fprintf ppf "@[<v 0>\003style\004\ @@ -896,24 +453,18 @@ let setup_formatter ppf ~format ~verbosity = .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" ; - | _ -> Pervasives.failwith "Cli_entries: invalid semantic tag" + | 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" -> Format.fprintf ppf "\003/span\004" - | "arg" -> Format.fprintf ppf "\003/span\004" - | "kwd" -> Format.fprintf ppf "\003/span\004" - | "hilight" -> () + | "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" - | "full" -> pop_level `Full - | "args" -> pop_level `Args - | "short" -> pop_level `Short - | "terse" -> pop_level `Terse | "document" -> Format.fprintf ppf "@]" - | _ -> Pervasives.failwith "Cli_entries: invalid semantic tag" + | other -> pop_level_tag other end } ; let orig_out_functions = Format.pp_get_formatter_out_functions ppf () in @@ -939,61 +490,439 @@ let restore_formatter ppf (out_functions, tag_functions, tags) = Format.pp_set_formatter_tag_functions ppf tag_functions ; Format.pp_set_print_tags ppf tags - -let usage ppf ?global_options ?(highlights=[]) commands format verbosity = - ignore (setup_formatter ppf ~format ~verbosity) ; - let usage ppf (by_group, options) = - let exe = Filename.basename Sys.executable_name in - let print_groups = - Format.pp_print_list - ~pp_sep: (fun ppf () -> Format.fprintf ppf "@,@,") - (print_group (print_command ?prefix:None ~highlights)) in - match options with - | None -> - Format.fprintf ppf - "@[<v>%a@]" - print_groups by_group - | Some (Argument { spec ; _ })-> - Format.fprintf ppf - "@[<v>@{<title>Usage@}@,\ - @{<list>\ - @{<command>@{<commandline>\ - %s [@{<opt>global options@}] command @{<opt>[command options]@}@}@}@,\ - @{<command>@{<commandline>\ - %s @{<opt>-help@} (for global options)@}@}@,\ - @{<command>@{<commandline>\ - %s [@{<opt>global options@}] command @{<opt>-help@} (for command options)@}@}\ - @}@,@,\ - @{<title>To browse the documentation@}@,\ - @{<list>\ - @{<command>@{<commandline>\ - %s [@{<opt>global options@}] man (for a list of commands)@}@}@,\ - @{<command>@{<commandline>\ - %s [@{<opt>global options@}] man @{<opt>-verbosity 3@} (for the full manual)@}@}\ - @}@,@,\ - @{<title>Global options (must come before the command)@}@,\ - @{<commanddoc>%a@}%a\ - %a@]" - exe exe exe exe exe - print_options_detailed spec - (fun ppf () -> if by_group <> [] then Format.fprintf ppf "@,@,") () - print_groups by_group in - Format.fprintf ppf "@{<document>%a" usage (group_commands commands, global_options) ; - if List.mem verbosity [ `Terse ; `Short ] then - Format.fprintf ppf "@\n@\nUse option [@{<opt>-verbosity 3@}] for option descriptions." ; - Format.fprintf ppf "@}" - -let command_usage ppf commands format verbosity = - ignore (setup_formatter ppf ~format ~verbosity) ; - let exe = Filename.basename Sys.executable_name in - let prefix ppf () = - Format.fprintf ppf "@{<kwd>%s@} @{<opt>[global options]@} " exe in +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 - "@[<v 2>@{<title>Command usage@}@,\ - %a@,@{<kwd>%s@} @{<opt>-help@} (for global options)@]" - (Format.pp_print_list (print_command ~prefix ~highlights:[])) - commands - exe + "@{<document>@{<title>Usage@}@,\ + @{<list>\ + @{<command>@{<commandline>\ + %s [@{<opt>global options@}] command @{<opt>[command options]@}@}@}@,\ + @{<command>@{<commandline>\ + %s @{<opt>-help@} (for global options)@}@}@,\ + @{<command>@{<commandline>\ + %s [@{<opt>global options@}] command @{<opt>-help@} (for command options)@}@}\ + @}@,@,\ + @{<title>To browse the documentation@}@,\ + @{<list>\ + @{<command>@{<commandline>\ + %s [@{<opt>global options@}] man (for a list of commands)@}@}@,\ + @{<command>@{<commandline>\ + %s [@{<opt>global options@}] man @{<opt>-verbosity 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 arg ~doc ~parameter ~placeholder kind = + Arg { doc ; + parameter ; + placeholder ; + kind } + +let default_arg ~doc ~parameter ~placeholder ~default kind = + DefArg { doc ; + placeholder ; + parameter ; + kind ; + default } + +let switch ~doc ~parameter = + Switch { doc ; parameter } + +let parse_arg : + type a ctx. ?command:_ command -> (a, ctx) arg -> string option TzString.Map.t -> ctx -> a tzresult Lwt.t = + fun ?command spec args_dict ctx -> + match spec with + | Arg { parameter ; kind = { converter ; _ } ; _ } -> + begin + try + begin + match TzString.Map.find parameter args_dict with + | None -> return None + | Some s -> + (trace + (Bad_option_argument (parameter, command)) + (converter ctx s)) >>|? fun x -> + Some x + end + with Not_found -> + return None + end + | DefArg { parameter ; 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." + parameter) end >>=? fun default -> + begin try + match TzString.Map.find parameter args_dict with + | None -> return default + | Some s -> + trace + (Bad_option_argument (parameter, command)) + (converter ctx s) + with Not_found -> return default + end + | Switch { parameter ; _ } -> + return (TzString.Map.mem parameter args_dict) + +(* Argument parsing *) +let rec parse_args : + type a ctx. ?command:_ command -> (a, ctx) args -> string option TzString.Map.t -> ctx -> a tzresult Lwt.t = + fun ?command spec args_dict ctx -> + match spec with + | NoArgs -> return () + | 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. int TzString.Map.t -> (a, b) args -> int TzString.Map.t = + fun acc -> function + | NoArgs -> acc + | AddArg (arg, rest) -> + let recur parameter num = + make_arities_dict (TzString.Map.add parameter num acc) rest in + begin + match arg with + | Arg { parameter ; _ } -> recur parameter 1 + | DefArg { parameter ; _ } -> recur parameter 1 + | Switch { parameter ; _ } -> recur parameter 0 + end + +type error += Help : 'a command option -> error + +let check_help_flag ?command = function + | ("-help" | "--help") :: _ -> fail (Help command) + | _ -> return () + +(* ignore_autocomplete is a hack to have the initial arguments get parsed + even if autocomplete command is running *) +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 TzString.Map.mem arg arities + then let arity = TzString.Map.find arg arities in + check_help_flag ?command tl >>=? fun () -> + match arity, tl with + | 0, tl' -> make_args_dict completing arities (TzString.Map.add arg None acc) tl' + | 1, value :: tl' -> + make_args_dict completing arities (TzString.Map.add arg (Some 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 return (acc, args) + in make_args_dict false (make_arities_dict TzString.Map.empty spec) 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 = TzString.Map.find arg arities in + check_help_flag ?command tl >>=? fun () -> + match arity, tl with + | 0, tl -> make_args_dict arities (TzString.Map.add arg None dict, other_args) tl + | 1, value :: tl' -> make_args_dict arities (TzString.Map.add arg (Some 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 TzString.Map.empty spec) + (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 } + +(* 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 "Cli_entries.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 + "Cli_entries.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 _ ; _}), ("-help" | "--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, command)) + else + fail (Extra_arguments (unparsed, command)) + end + | TSeq (Command { options = Argument { spec ; _ } ; _ } as command, _), remaining -> + if List.exists (function "-help" | "--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 }, ([] | ("-help" | "--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 ; _ }, ([] | ("-help" | "--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 : type a ctx. (a, ctx) arg -> string = function | Arg { parameter ; _ } -> parameter @@ -1105,9 +1034,8 @@ let complete_tree cctxt tree index args = | TEmpty, _ -> return [] in help tree args index - -let autocomplete ~script ~cur_arg ~prev_arg ~args ~tree ~global_options cctxt = - (* Interp: (ind 0) is the index of the cursor *) +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 -> @@ -1118,166 +1046,189 @@ let autocomplete ~script ~cur_arg ~prev_arg ~args ~tree ~global_options cctxt = if prev_arg = script then complete_next_tree cctxt tree >>|? fun command_completions -> begin - match global_options with - | None -> command_completions - | Some (Argument { spec ; _ }) -> - remaining_spec StringSet.empty spec - @ command_completions + let (Argument { spec ; _ }) = global_options in + remaining_spec StringSet.empty spec @ command_completions end else match ind 0 args with - | None -> return [] + | None -> + return [] | Some index -> begin - match global_options with - | None -> complete_tree cctxt tree index args - | Some (Argument { spec ; _ }) -> - complete_options (fun args ind -> complete_tree cctxt tree ind args) - args spec index cctxt + 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 -(* Try a list of commands on a list of arguments *) -let dispatch ?global_options commands ctx args = - let commands = help_commands commands @ commands in +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 - | [] | [ "-help" | "--help" ] -> fail Bare_help - | "bash_autocomplete" :: prev_arg :: cur_arg :: script :: remaining_args -> - autocomplete ~script ~cur_arg ~prev_arg ~args:remaining_args ~global_options ~tree ctx - >>= fun completions -> - fail (Autocomplete_command - (match completions with - | Ok completions -> completions - | Error _ -> [])) + | [] | [ "-help" | "--help" ] -> + fail (Help None) | _ -> find_command tree args >>=? fun (command, args_dict, filtered_args) -> exec command ctx filtered_args args_dict -let handle_cli_errors ~stdout ~stderr ~global_options = function - | Ok _ -> - return 0 - | Error [ e ] -> (* Should only be one error here *) - begin match e with - | Extra_arguments (_, cmd) -> - ignore (setup_formatter stderr ~format:(if Unix.isatty Unix.stderr then `Ansi else `Plain) ~verbosity:`Terse) ; - Format.fprintf stderr - "Extra arguments provided for command:@;<1 2>@[%a@]@." - (print_command ?prefix:None ~highlights:[]) cmd; - return 1 - | Not_enough_args (_, cmds) -> - ignore (setup_formatter stderr ~format:(if Unix.isatty Unix.stderr then `Ansi else `Plain) ~verbosity:`Terse) ; - Format.fprintf stderr - "@[<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))) cmds; - return 1 - | Command_not_found ([], _) -> - Format.fprintf stderr - "Unrecognized command. Try using the 'man' command to get more information.@." ; - return 1 - | Command_not_found (_, cmds) -> - Format.fprintf stderr - "@[<v 2>Unrecognized command, did you mean one of the following:@,%a@]@." - (Format.pp_print_list - (fun ppf (Command { params ; options = Argument { spec ; _ } ; _ }) -> - print_commandline ppf ([], spec, params))) cmds; - return 1 - | Bad_argument (pos, arg) -> - Format.fprintf stderr - "The argument '%s' given in position %d was invalid.@." - arg - pos ; - return 1 - | Option_expected_argument option -> - Format.fprintf stderr - "The option '%s' expected an argument, but you did not provide one.@." - option ; - return 1 - | Unknown_option option -> - Format.fprintf stderr - "While parsing options, encountered unexpected argument '%s'.@." - option ; - return 1 - | Help_cmd ([ highlight ], [], _, _) -> - Format.fprintf stderr "No command found that match %s.@." highlight ; - return 0 - | Help_cmd (highlight :: highlights, [], _, _) -> - Format.fprintf stderr "No command found that match %a%s and %s.@." - (Format.pp_print_list - ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ") - (fun ppf s -> Format.fprintf ppf "%s" s)) highlights - (match highlights with [ _ ] | [] -> "" | _::_ -> ",") - highlight ; - return 0 - | Help_cmd (highlights, commands, format, verbosity) -> - let global_options = - if highlights = [] then Some global_options else None in - usage stdout ?global_options ~highlights commands format verbosity ; - Format.fprintf stdout "@." ; - return 0 - | Bare_help -> - let format = if Unix.isatty Unix.stdout then `Ansi else `Plain in - usage stdout ~global_options ?highlights:None [] format `Terse ; - Format.fprintf stdout "@." ; - return 0 - | Autocomplete_command (completions) -> - Format.fprintf stdout "%a@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_newline - Format.pp_print_string) - completions ; - return 0 - | Help_flag commands -> - let format = if Unix.isatty Unix.stdout then `Ansi else `Plain in - command_usage stdout commands format `Verbose ; - Format.fprintf stdout "@." ; - return 0 - | e -> fail e - end - | (Error _) as errors -> Lwt.return errors +type error += No_manual_entry of string list -let () = - register_error_kind - `Branch - ~id: "cli.bad_argument" - ~title: "Bad argument" - ~description: "Error in a command line argument" - ~pp: - (fun ppf (i, v) -> - Format.fprintf ppf "Error in command line argument %d (%s)" i v) - Data_encoding.(obj2 (req "index" uint8) (req "value" string)) - (function Bad_argument (i, v) -> Some (i, v) | _ -> None) - (fun (i, v) -> Bad_argument (i, v)) ; - register_error_kind - `Branch - ~id: "cli.option_expected_argument" - ~title: "Option without argument" - ~description: "Option expected argument, but did not receive one" - ~pp: - (fun ppf arg -> - Format.fprintf ppf "The option '%s' expected an argument, but did not receive one" arg) - Data_encoding.(obj1 (req "arg" string)) - (function Option_expected_argument arg -> Some arg | _ -> None) - (fun arg -> Option_expected_argument arg) ; - register_error_kind - `Branch - ~id: "cli.unknown_option" - ~title: "Unknown option" - ~description: "While parsing options, encountered unknown option" - ~pp: - (fun ppf arg -> - Format.fprintf ppf - (if (String.length arg) > 0 && (String.get arg 0) = '-' - then "Encountered an unknown option '%s' while parsing the command" - else "Expected a flag, but instead encountered '%s'") arg) - Data_encoding.(obj1 (req "arg" string)) - (function Unknown_option arg -> Some arg | _ -> None) - (fun arg -> Unknown_option arg) +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" + ~parameter:"-verbosity" + ~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" + ~parameter: "-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 ()) ]) 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 ; + [] + | Option_expected_argument (arg, command) -> + Format.fprintf ppf + "Command line option @{<opt>%s@} expects an argument." arg ; + 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 ; + 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 ; + [] + | 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 ; + [] + | Unknown_option (option, command) -> + Format.fprintf ppf + "Unexpected command line option @{<opt>%s@}." + option ; + [ Ex 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 ; + [ 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 ; + 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.@]" ; + [] + | 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 ; + List.map (fun c -> Ex c) commands + | err -> default ppf err ; [] in + let rec pp acc = function + | [] -> [] + | [ last ] -> pp_one last @ acc + | err :: errs -> + let acc = pp_one err @ acc in + Format.fprintf ppf "@," ; + pp acc errs in + Format.fprintf ppf "@[<v 2>@{<error>@{<title>Error@}@}@," ; + let commands = pp [] errs in + Format.fprintf ppf "@]@.@[<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)) }) diff --git a/src/lib_base/cli_entries.mli b/src/lib_base/cli_entries.mli index 76329ea69..30e06abae 100644 --- a/src/lib_base/cli_entries.mli +++ b/src/lib_base/cli_entries.mli @@ -81,7 +81,7 @@ val switch : doc:string -> parameter:string -> (** {2 Groups of Optional Arguments} *) (** Defines a group of options, either the global options or the - command options. *) + command options. *) (** The type of a series of labeled arguments to a command *) type ('a, 'ctx) options @@ -163,56 +163,56 @@ val args10 : ('a, 'ctx) arg -> ('b, 'ctx) arg -> ('c, 'ctx) arg -> ('d, 'ctx) ar (** {2 Parameter based command lines} *) (** Type of parameters for a command *) -type ('a, 'ctx, 'ret) params +type ('a, 'ctx) params (** A piece of data inside a command line *) val param: name: string -> desc: string -> ('a, 'ctx) parameter -> - ('b, 'ctx, 'ret) params -> - ('a -> 'b, 'ctx, 'ret) params + ('b, 'ctx) params -> + ('a -> 'b, 'ctx) params (** A word in a command line. Should be descriptive. *) val prefix: string -> - ('a, 'ctx, 'ret) params -> - ('a, 'ctx, 'ret) params + ('a, 'ctx) params -> + ('a, 'ctx) params (** Multiple words given in sequence for a command line *) val prefixes: string list -> - ('a, 'ctx, 'ret) params -> - ('a, 'ctx, 'ret) params + ('a, 'ctx) params -> + ('a, 'ctx) params (** A fixed series of words that trigger a command. *) val fixed: string list -> - ('ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params + ('ctx -> unit tzresult Lwt.t, 'ctx) params (** End the description of the command line *) val stop: - ('ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params + ('ctx -> unit tzresult Lwt.t, 'ctx) params (** Take a sequence of parameters instead of only a single one. Must be the last thing in the command line. *) val seq_of_param: - (('ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params -> - ('a -> 'ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params) -> - ('a list -> 'ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params + (('ctx -> unit tzresult Lwt.t, 'ctx) params -> + ('a -> 'ctx -> unit tzresult Lwt.t, 'ctx) params) -> + ('a list -> 'ctx -> unit tzresult Lwt.t, 'ctx) params (** Parameter that expects a string *) val string: name: string -> desc: string -> - ('a, 'ctx, 'ret) params -> - (string -> 'a, 'ctx, 'ret) params + ('a, 'ctx) params -> + (string -> 'a, 'ctx) params (** {2 Commands } *) (** Command, including a parameter specification, optional arguments, and handlers *) -type ('ctx, 'ret) command +type 'ctx command (** Type of a group of commands. Groups have their documentation printed together @@ -222,49 +222,30 @@ type group = title : string } (** A complete command, with documentation, a specification of its - options, parameters, and handler function. *) + options, parameters, and handler function. *) val command: ?group: group -> desc: string -> ('b, 'ctx) options -> - ('a, 'ctx, 'ret) params -> + ('a, 'ctx) params -> ('b -> 'a) -> - ('ctx, 'ret) command + 'ctx command -(** {2 Parsing and error reporting} *) - -(** Print readable descriptions for CLI parsing errors. - This function must be used for help printing to work. *) -val handle_cli_errors: - stdout: Format.formatter -> - stderr: Format.formatter -> - global_options:(_, _) options -> - 'a tzresult -> int tzresult Lwt.t - -(** Find and call the applicable command on the series of arguments. - @raises [Failure] if the command list would be ambiguous. *) -val dispatch: - ?global_options:('a, 'ctx) options -> - ('ctx, 'ret) command list -> - 'ctx -> - string list -> - 'ret tzresult Lwt.t - -(** Parse the global options, and return their value, with the rest of - the command to be parsed. *) -val parse_initial_options : - ('a, 'ctx) options -> - 'ctx -> - string list -> - ('a * string list) tzresult Lwt.t - -val map_command: ('a -> 'b) -> ('b, 'c) command -> ('a, 'c) command +(** Combinator to use a command in an adaptated context. *) +val map_command: ('a -> 'b) -> 'b command -> 'a command (** {2 Output formatting} *) (** Used to restore the formatter state after [setup_formatter]. *) type formatter_state +(** Supported output formats. + Currently: black and white, colors using ANSI escapes, and HTML.*) +type format = Plain | Ansi | Html + +(** Verbosity level, from terse to verbose. *) +type verbosity = Terse | Short | Details | Full + (** Updates the formatter's functions to interprete some semantic tags used in manual production. Returns the previous state of the formatter to restore it afterwards if needed. @@ -275,28 +256,86 @@ type formatter_state * [<title>]: a section title (just below a [<document]) * [<list>]: a list section (just below a [<document]) - Structure tags used internally for generating the manual: + Structure tags used internally for generating the manual: * [<command>]: wraps the full documentation bloc for a command * [<commandline>]: wraps the command line in a [<command>] * [<commanddoc>]: wraps everything but the command line in a [<command>] - Cosmetic tags for hilighting text: + Cosmetic tags for hilighting text: * [<opt>]: optional arguments * [<arg>]: positional arguments * [<kwd>]: positional keywords * [<hilight>]: search results - Verbosity levels, in order, and how they are used in the manual: + Verbosity levels, in order, and how they are used in the manual: - * [<terse>]: always displayed (titles commands lines) - * [<args>]: displayed if [verbosity >= `Args] (lists of arguments) - * [<short>]: displayed if [verbosity >= `Short] (single line descriptions) - * [<full>]: only displayed if [verbosity = `Full] (long descriptions) *) + * [<terse>]: titles, commands lines + * [<short>]: lists of arguments + * [<details>]: single line descriptions + * [<full>]: with long descriptions + + Wrapping a piece of text with a debug level means that the + contents are only printed if the verbosity is equal to or + above that level. Use prefix [=] for an exact match, or [-] + for the inverse interpretation. *) val setup_formatter : Format.formatter -> - format: [< `Ansi | `Html | `Plain ] -> - verbosity: [> `Terse | `Short | `Args | `Full ] -> + format -> + verbosity -> formatter_state (** Restore the formatter state after [setup_formatter]. *) val restore_formatter : Format.formatter -> formatter_state -> unit + +(** {2 Parsing and error reporting} *) + +(** Help error (not really an error), thrown by {!dispatch} and {!parse_initial_options}. *) +type error += Help : _ command option -> error + +(** Find and call the applicable command on the series of arguments. + @raises [Failure] if the command list would be ambiguous. *) +val dispatch: 'ctx command list -> 'ctx -> string list -> unit tzresult Lwt.t + +(** Parse the global options, and return their value, with the rest of + the command to be parsed. *) +val parse_global_options : ('a, 'ctx) options -> 'ctx -> string list -> ('a * string list) tzresult Lwt.t + +(** Pretty printfs the error messages to the given formatter. + [executable_name] and [global_options] are for help screens. + [default] is used to print non-cli errors. *) +val pp_cli_errors : + Format.formatter -> + executable_name: string -> + global_options: (_, _) options -> + default: (Format.formatter -> error -> unit) -> + error list -> + unit + +(** Acts as {!dispatch}, but stops if the given command up to + [prev_arg] is a valid prefix command, returning the list of valid + next words, filtered with [cur_arg]. *) +val autocompletion : + script:string -> cur_arg:string -> prev_arg:string -> args:string list -> + global_options:('a, 'ctx) options -> 'ctx command list -> 'ctx -> + string list Error_monad.tzresult Lwt.t + +(** Displays a help page for the given commands. *) +val usage : + Format.formatter -> + executable_name:string -> + global_options:(_, _) options -> + _ command list -> + unit + +(** {2 Manual} *) + +(** Add manual commands to a list of commands. + For this to work, the command list must be complete. + Commands added later will not appear in the manual. *) +val add_manual : + executable_name: string -> + global_options: ('a, 'ctx) options -> + format -> + Format.formatter -> + 'ctx command list -> + 'ctx command list diff --git a/src/lib_base/ed25519.mli b/src/lib_base/ed25519.mli index 92346ce7e..63f4c5ff9 100644 --- a/src/lib_base/ed25519.mli +++ b/src/lib_base/ed25519.mli @@ -10,8 +10,8 @@ module Public_key : sig val param: ?name:string -> ?desc:string -> - ('a, 'b, 'c) Cli_entries.params -> - (t -> 'a, 'b, 'c) Cli_entries.params + ('a, 'b) Cli_entries.params -> + (t -> 'a, 'b) Cli_entries.params val of_b58check: string -> t tzresult end @@ -21,8 +21,8 @@ module Secret_key : sig val param: ?name:string -> ?desc:string -> - ('a, 'b, 'c) Cli_entries.params -> - (t -> 'a, 'b, 'c) Cli_entries.params + ('a, 'b) Cli_entries.params -> + (t -> 'a, 'b) Cli_entries.params val of_b58check: string -> t tzresult end @@ -32,8 +32,8 @@ module Signature : sig val param: ?name:string -> ?desc:string -> - ('a, 'b, 'c) Cli_entries.params -> - (t -> 'a, 'b, 'c) Cli_entries.params + ('a, 'b) Cli_entries.params -> + (t -> 'a, 'b) Cli_entries.params val of_b58check: string -> t tzresult end diff --git a/src/lib_base/s.ml b/src/lib_base/s.ml index 871129449..27fe31391 100644 --- a/src/lib_base/s.ml +++ b/src/lib_base/s.ml @@ -78,8 +78,8 @@ module type INTERNAL_HASH = sig val param: ?name:string -> ?desc:string -> - ('a, 'arg, 'ret) Cli_entries.params -> - (t -> 'a, 'arg, 'ret) Cli_entries.params + ('a, 'arg) Cli_entries.params -> + (t -> 'a, 'arg) Cli_entries.params module Set : sig include Set.S with type elt = t @@ -128,8 +128,8 @@ module type INTERNAL_MERKLE_TREE = sig val param: ?name:string -> ?desc:string -> - ('a, 'arg, 'ret) Cli_entries.params -> - (t -> 'a, 'arg, 'ret) Cli_entries.params + ('a, 'arg) Cli_entries.params -> + (t -> 'a, 'arg) Cli_entries.params module Set : sig include Set.S with type elt = t diff --git a/src/lib_client_base/client_admin.mli b/src/lib_client_base/client_admin.mli index 477b5fc32..f75ebea1c 100644 --- a/src/lib_client_base/client_admin.mli +++ b/src/lib_client_base/client_admin.mli @@ -7,4 +7,4 @@ (* *) (**************************************************************************) -val commands : unit -> (#Client_commands.full_context, unit) Cli_entries.command list +val commands : unit -> #Client_commands.full_context Cli_entries.command list diff --git a/src/lib_client_base/client_aliases.ml b/src/lib_client_base/client_aliases.ml index abfe459bd..bbab98779 100644 --- a/src/lib_client_base/client_aliases.ml +++ b/src/lib_client_base/client_aliases.ml @@ -60,13 +60,13 @@ module type Alias = sig val alias_param : ?name:string -> ?desc:string -> - ('a, (#Client_commands.wallet as 'b), 'ret) Cli_entries.params -> - (string * t -> 'a, 'b, 'ret) Cli_entries.params + ('a, (#Client_commands.wallet as 'b)) Cli_entries.params -> + (string * t -> 'a, 'b) Cli_entries.params val fresh_alias_param : ?name:string -> ?desc:string -> - ('a, (< .. > as 'obj), 'ret) Cli_entries.params -> - (fresh_param -> 'a, 'obj, 'ret) Cli_entries.params + ('a, (< .. > as 'obj)) Cli_entries.params -> + (fresh_param -> 'a, 'obj) Cli_entries.params val force_switch : unit -> (bool, #Client_commands.full_context) arg val of_fresh : @@ -77,8 +77,8 @@ module type Alias = sig val source_param : ?name:string -> ?desc:string -> - ('a, (#Client_commands.wallet as 'obj), 'ret) Cli_entries.params -> - (t -> 'a, 'obj, 'ret) Cli_entries.params + ('a, (#Client_commands.wallet as 'obj)) Cli_entries.params -> + (t -> 'a, 'obj) Cli_entries.params val autocomplete: #Client_commands.wallet -> string list tzresult Lwt.t end diff --git a/src/lib_client_base/client_aliases.mli b/src/lib_client_base/client_aliases.mli index 1cf25e895..9b5421e4a 100644 --- a/src/lib_client_base/client_aliases.mli +++ b/src/lib_client_base/client_aliases.mli @@ -56,13 +56,13 @@ module type Alias = sig val alias_param : ?name:string -> ?desc:string -> - ('a, (#Client_commands.wallet as 'b), 'ret) Cli_entries.params -> - (string * t -> 'a, 'b, 'ret) Cli_entries.params + ('a, (#Client_commands.wallet as 'b)) Cli_entries.params -> + (string * t -> 'a, 'b) Cli_entries.params val fresh_alias_param : ?name:string -> ?desc:string -> - ('a, (< .. > as 'obj), 'ret) Cli_entries.params -> - (fresh_param -> 'a, 'obj, 'ret) Cli_entries.params + ('a, (< .. > as 'obj)) Cli_entries.params -> + (fresh_param -> 'a, 'obj) Cli_entries.params val force_switch : unit -> (bool, #Client_commands.full_context) Cli_entries.arg val of_fresh : @@ -73,8 +73,8 @@ module type Alias = sig val source_param : ?name:string -> ?desc:string -> - ('a, (#Client_commands.wallet as 'obj), 'ret) Cli_entries.params -> - (t -> 'a, 'obj, 'ret) Cli_entries.params + ('a, (#Client_commands.wallet as 'obj)) Cli_entries.params -> + (t -> 'a, 'obj) Cli_entries.params val autocomplete: #Client_commands.wallet -> string list tzresult Lwt.t end diff --git a/src/lib_client_base/client_commands.ml b/src/lib_client_base/client_commands.ml index 3214e52d6..d628217b9 100644 --- a/src/lib_client_base/client_commands.ml +++ b/src/lib_client_base/client_commands.ml @@ -121,7 +121,7 @@ class file_wallet dir : wallet = object (self) |> generic_trace "could not write the %s alias file." alias_name end -type command = (full_context, unit) Cli_entries.command +type command = full_context Cli_entries.command (* Default config *) diff --git a/src/lib_client_base/client_commands.mli b/src/lib_client_base/client_commands.mli index c754aa449..9ff41e96e 100644 --- a/src/lib_client_base/client_commands.mli +++ b/src/lib_client_base/client_commands.mli @@ -70,7 +70,7 @@ val ignore_context : full_context (** [ignore_context] is a context whose logging callbacks do nothing, and whose [error] function calls [Lwt.fail_with]. *) -type command = (full_context, unit) Cli_entries.command +type command = full_context Cli_entries.command exception Version_not_found diff --git a/src/lib_client_base/client_config.ml b/src/lib_client_base/client_config.ml index 1dd1ffebe..76e75e9e0 100644 --- a/src/lib_client_base/client_config.ml +++ b/src/lib_client_base/client_config.ml @@ -20,7 +20,7 @@ let () = ~description: "Block argument could not be parsed" ~pp: (fun ppf s -> - Format.fprintf ppf "Value provided for -block flag (%s) could not be parsed" s) + Format.fprintf ppf "Value %s is not a value block reference." s) Data_encoding.(obj1 (req "value" string)) (function Invalid_block_argument s -> Some s | _ -> None) (fun s -> Invalid_block_argument s) ; @@ -31,7 +31,7 @@ let () = ~description: "Protocol argument could not be parsed" ~pp: (fun ppf s -> - Format.fprintf ppf "Value provided for -protocol flag (%s) does not correspond to any known protocol" s) + Format.fprintf ppf "Value %s does not correspond to any known protocol." s) Data_encoding.(obj1 (req "value" string)) (function Invalid_protocol_argument s -> Some s | _ -> None) (fun s -> Invalid_protocol_argument s) ; @@ -42,7 +42,7 @@ let () = ~description: "Port argument could not be parsed" ~pp: (fun ppf s -> - Format.fprintf ppf "Value provided for -port flag (%s) could not be parsed" s) + Format.fprintf ppf "Value %s is not a valid TCP port." s) Data_encoding.(obj1 (req "value" string)) (function Invalid_port_arg s -> Some s | _ -> None) (fun s -> Invalid_port_arg s) @@ -282,7 +282,7 @@ let global_options () = (tls_switch ()) let parse_config_args (ctx : #Client_commands.full_context) argv = - parse_initial_options + parse_global_options (global_options ()) ctx argv >>=? diff --git a/src/lib_client_base/client_debug.mli b/src/lib_client_base/client_debug.mli index 204d22ee5..28884861b 100644 --- a/src/lib_client_base/client_debug.mli +++ b/src/lib_client_base/client_debug.mli @@ -8,4 +8,4 @@ (**************************************************************************) -val commands : unit -> (#Client_commands.full_context, unit) Cli_entries.command list +val commands : unit -> #Client_commands.full_context Cli_entries.command list diff --git a/src/lib_client_base/client_tags.mli b/src/lib_client_base/client_tags.mli index fc58316ce..f32196c35 100644 --- a/src/lib_client_base/client_tags.mli +++ b/src/lib_client_base/client_tags.mli @@ -28,8 +28,8 @@ module Tags (Entity : Entity) : sig val tag_param: ?name:string -> ?desc:string -> - ('a, 'ctx, 'ret) Cli_entries.params -> - (Tag.t -> 'a, 'ctx, 'ret) Cli_entries.params + ('a, 'ctx) Cli_entries.params -> + (Tag.t -> 'a, 'ctx) Cli_entries.params val rev_find_by_tag: #Client_commands.full_context -> diff --git a/src/proto_alpha/lib_client/client_baking_main.mli b/src/proto_alpha/lib_client/client_baking_main.mli index dc60437ab..400a4afe1 100644 --- a/src/proto_alpha/lib_client/client_baking_main.mli +++ b/src/proto_alpha/lib_client/client_baking_main.mli @@ -7,4 +7,4 @@ (* *) (**************************************************************************) -val commands: unit -> (Proto_alpha.full_context, unit) Cli_entries.command list +val commands: unit -> Proto_alpha.full_context Cli_entries.command list diff --git a/src/proto_alpha/lib_client/client_proto_args.mli b/src/proto_alpha/lib_client/client_proto_args.mli index 5f9797a87..0326d3e6b 100644 --- a/src/proto_alpha/lib_client/client_proto_args.mli +++ b/src/proto_alpha/lib_client/client_proto_args.mli @@ -35,8 +35,8 @@ val tez_arg : val tez_param : name:string -> desc:string -> - ('a, full_context, 'ret) Cli_entries.params -> - (Tez.t -> 'a, full_context, 'ret) Cli_entries.params + ('a, full_context) Cli_entries.params -> + (Tez.t -> 'a, full_context) Cli_entries.params module Daemon : sig val baking_switch: (bool, Proto_alpha.full_context) Cli_entries.arg diff --git a/src/proto_alpha/lib_client/client_proto_contracts.mli b/src/proto_alpha/lib_client/client_proto_contracts.mli index 419d717da..699d9580e 100644 --- a/src/proto_alpha/lib_client/client_proto_contracts.mli +++ b/src/proto_alpha/lib_client/client_proto_contracts.mli @@ -21,13 +21,13 @@ module ContractAlias : sig val alias_param: ?name:string -> ?desc:string -> - ('a, (#Client_commands.wallet as 'wallet), 'ret) params -> - (Lwt_io.file_name * Contract.t -> 'a, 'wallet, 'ret) params + ('a, (#Client_commands.wallet as 'wallet)) params -> + (Lwt_io.file_name * Contract.t -> 'a, 'wallet) params val destination_param: ?name:string -> ?desc:string -> - ('a, (#Client_commands.wallet as 'wallet), 'ret) params -> - (Lwt_io.file_name * Contract.t -> 'a, 'wallet, 'ret) params + ('a, (#Client_commands.wallet as 'wallet)) params -> + (Lwt_io.file_name * Contract.t -> 'a, 'wallet) params val rev_find: #Client_commands.wallet -> Contract.t -> string option tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/client_proto_programs_commands.mli b/src/proto_alpha/lib_client/client_proto_programs_commands.mli index dc60437ab..400a4afe1 100644 --- a/src/proto_alpha/lib_client/client_proto_programs_commands.mli +++ b/src/proto_alpha/lib_client/client_proto_programs_commands.mli @@ -7,4 +7,4 @@ (* *) (**************************************************************************) -val commands: unit -> (Proto_alpha.full_context, unit) Cli_entries.command list +val commands: unit -> Proto_alpha.full_context Cli_entries.command list