balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

CLI: Autocomplete

Browse Source
This commit is contained in:
Milo Davis 2017-09-27 09:55:20 +02:00 committed by Benjamin Canou
parent 7d20da9a7b
commit 466831c179
17 changed files with 459 additions and 195 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
scripts/bash-completion.sh Normal file
View File

@ -0,0 +1,18 @@
_tezos-client_complete()
{
local cur_word prev_word type_list
cur_word="${COMP_WORDS[COMP_CWORD]}"
prev_word="${COMP_WORDS[COMP_CWORD-1]}"
# Tezos script
script=${COMP_WORDS[0]}
reply=$($script bash_autocomplete "$prev_word" "$cur_word" ${COMP_WORDS[@]})
COMPREPLY=($(compgen -W "$reply"))
return 0
}
# Register _pss_complete to provide completion for the following commands
complete -F _tezos-client_complete tezos-client

109
src/client/client_aliases.ml
View File

@ -77,6 +77,8 @@ module type Alias = sig
?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params ->
(t -> 'a, Client_commands.context, 'ret) Cli_entries.params
val autocomplete:
Client_commands.context -> string list tzresult Lwt.t
end
module Alias = functor (Entity : Entity) -> struct
@ -109,6 +111,11 @@ module Alias = functor (Entity : Entity) -> struct
| list ->
return list
let autocomplete cctxt =
load cctxt >>= function
| Error _ -> return []
| Ok list -> return (List.map fst list)
let find_opt cctxt name =
load cctxt >>=? fun list ->
try return (Some (List.assoc name list))
@ -207,24 +214,24 @@ module Alias = functor (Entity : Entity) -> struct
let alias_param
?(name = "name") ?(desc = "existing " ^ Entity.name ^ " alias") next =
param ~name ~desc
(fun cctxt s ->
find cctxt s >>=? fun v ->
return (s, v))
(parameter (fun cctxt s ->
find cctxt s >>=? fun v ->
return (s, v)))
next
let fresh_alias_param
?(name = "new") ?(desc = "new " ^ Entity.name ^ " alias") next =
param ~name ~desc
(fun cctxt s ->
begin
load cctxt >>=? fun list ->
(parameter (fun cctxt s ->
begin
if cctxt.config.force then
return ()
else
iter_s
(fun (n, _v) ->
if n = s then
load cctxt >>=? fun list ->
begin
if cctxt.config.force then
return ()
else
iter_s
(fun (n, _v) ->
if n = s then
Entity.to_source cctxt _v >>=? fun value ->
failwith
"@[<v 2>The %s alias %s already exists.@,\
@ -232,12 +239,12 @@ module Alias = functor (Entity : Entity) -> struct
Use -force true to update@]"
Entity.name n
value
else
return ())
list
end
end >>=? fun () ->
return s)
else
return ())
list
end
end >>=? fun () ->
return s))
next
let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next =
@ -246,39 +253,39 @@ module Alias = functor (Entity : Entity) -> struct
^ "can be an alias, file or literal (autodetected in this order)\n\
use 'file:path', 'text:literal' or 'alias:name' to force" in
param ~name ~desc
(fun cctxt s ->
let read path =
Lwt.catch
(fun () ->
Lwt_io.(with_file ~mode:Input path read) >>= fun content ->
return content)
(fun exn ->
failwith
"cannot read file (%s)" (Printexc.to_string exn))
>>=? fun content ->
of_source cctxt content in
begin
match Utils.split ~limit:1 ':' s with
| [ "alias" ; alias ]->
find cctxt alias
| [ "text" ; text ] ->
of_source cctxt text
| [ "file" ; path ] ->
read path
| _ ->
find cctxt s >>= function
| Ok v -> return v
| Error a_errs ->
read s >>= function
| Ok v -> return v
| Error r_errs ->
of_source cctxt s >>= function
| Ok v -> return v
| Error s_errs ->
let all_errs =
List.flatten [ a_errs ; r_errs ; s_errs ] in
Lwt.return (Error all_errs)
end)
(parameter (fun cctxt s ->
let read path =
Lwt.catch
(fun () ->
Lwt_io.(with_file ~mode:Input path read) >>= fun content ->
return content)
(fun exn ->
failwith
"cannot read file (%s)" (Printexc.to_string exn))
>>=? fun content ->
of_source cctxt content in
begin
match Utils.split ~limit:1 ':' s with
| [ "alias" ; alias ]->
find cctxt alias
| [ "text" ; text ] ->
of_source cctxt text
| [ "file" ; path ] ->
read path
| _ ->
find cctxt s >>= function
| Ok v -> return v
| Error a_errs ->
read s >>= function
| Ok v -> return v
| Error r_errs ->
of_source cctxt s >>= function
| Ok v -> return v
| Error s_errs ->
let all_errs =
List.flatten [ a_errs ; r_errs ; s_errs ] in
Lwt.return (Error all_errs)
end))
next
let name cctxt d =

2
src/client/client_aliases.mli
View File

@ -73,5 +73,7 @@ module type Alias = sig
?desc:string ->
('a, Client_commands.context, 'ret) Cli_entries.params ->
(t -> 'a, Client_commands.context, 'ret) Cli_entries.params
val autocomplete:
Client_commands.context -> string list tzresult Lwt.t
end
module Alias (Entity : Entity) : Alias with type t = Entity.t

28
src/client/client_config.ml
View File

@ -107,18 +107,28 @@ let default_cli_args = {
open Cli_entries
let string_parameter : (string, Client_commands.context) parameter =
parameter (fun _ x -> return x)
let block_parameter =
parameter
(fun _ block -> match Node_rpc_services.Blocks.parse_block block with
| Error _ ->
fail (Invalid_block_argument block)
| Ok block -> return block)
(* Command-line only args (not in config file) *)
let base_dir_arg =
default_arg
~parameter:"-base-dir"
~doc:"The directory where the Tezos client will store all its data."
~default:Client_commands.default_base_dir
(fun _ x -> return x)
string_parameter
let config_file_arg =
arg
~parameter:"-config-file"
~doc:"The main configuration file."
(fun _ x -> return x)
string_parameter
let timings_switch =
switch
~parameter:"-timings"
@ -132,10 +142,7 @@ let block_arg =
~parameter:"-block"
~doc:"The block on which to apply contextual commands."
~default:(Node_rpc_services.Blocks.to_string default_cli_args.block)
(fun _ block -> match Node_rpc_services.Blocks.parse_block block with
| Error _ ->
fail (Invalid_block_argument block)
| Ok block -> return block)
block_parameter
let log_requests_switch =
switch
~parameter:"-log-requests"
@ -147,16 +154,17 @@ let addr_arg =
~parameter:"-addr"
~doc:"The IP address of the node."
~default:Cfg_file.default.node_addr
(fun _ x -> return x)
string_parameter
let port_arg =
default_arg
~parameter:"-port"
~doc:"The RPC port of the node."
~default:(string_of_int Cfg_file.default.node_port)
(fun _ x -> try
(parameter
(fun _ x -> try
return (int_of_string x)
with Failure _ ->
fail (Invalid_port_arg x))
fail (Invalid_port_arg x)))
let tls_switch =
switch
~parameter:"-tls"
@ -173,7 +181,7 @@ let global_options =
port_arg
tls_switch
let parse_config_args (ctx : Client_commands.cfg) argv =
let parse_config_args (ctx : Client_commands.context) argv =
parse_initial_options
global_options
ctx

3
src/client/client_protocols.ml
View File

@ -20,6 +20,7 @@ let commands () =
return dn
else
failwith "%s is not a directory" dn in
let check_dir_parameter = parameter check_dir in
[
command ~group ~desc: "list known protocols"
@ -34,7 +35,7 @@ let commands () =
command ~group ~desc: "inject a new protocol to the shell database"
no_options
(prefixes [ "inject" ; "protocol" ]
@@ param ~name:"dir" ~desc:"directory containing a protocol" check_dir
@@ param ~name:"dir" ~desc:"directory containing a protocol" check_dir_parameter
@@ stop)
(fun () dirname cctxt ->
Lwt.catch

7
src/client/client_tags.ml
View File

@ -64,9 +64,10 @@ module Tags (Entity : Entity) = struct
let desc =
desc ^ "\n"
^ "can be one or multiple tags separated by commas" in
Cli_entries.param ~name ~desc
(fun cctxt s -> of_source cctxt s)
next
Cli_entries.(
param ~name ~desc
(parameter (fun cctxt s -> of_source cctxt s))
next)
let rev_find_by_tag cctxt tag =
load cctxt >>=? fun tags ->

37
src/client/embedded/alpha/client_proto_args.ml
View File

@ -53,26 +53,29 @@ let () =
let tez_sym =
"\xEA\x9C\xA9"
let string_parameter =
parameter (fun _ x -> return x)
let init_arg =
default_arg
~parameter:"-init"
~doc:"The initial value of the contract's storage."
~default:"Unit"
(fun _ s -> return s)
string_parameter
let arg_arg =
default_arg
~parameter:"-arg"
~doc:"The argument passed to the contract's script, if needed."
~default:"Unit"
(fun _ a -> return a)
string_parameter
let delegate_arg =
arg
~parameter:"-delegate"
~doc:"Set the delegate of the contract.\
Must be a known identity."
(fun _ s -> return s)
string_parameter
let source_arg =
@ -80,7 +83,7 @@ let source_arg =
~parameter:"-source"
~doc:"Set the source of the bonds to be paid.\
Must be a known identity."
(fun _ s -> return s)
string_parameter
let non_spendable_switch =
switch
@ -101,21 +104,21 @@ let delegatable_switch =
let tez_format = "text format: D,DDD,DDD.DD (centiles are optional, commas are optional)"
let tez_arg ~default ~parameter ~doc =
default_arg ~parameter ~doc ~default
let tez_parameter param =
parameter
(fun _ s ->
match Tez.of_string s with
| Some tez -> return tez
| None -> fail (Bad_tez_arg (parameter, s)))
| None -> fail (Bad_tez_arg (param, s)))
let tez_arg ~default ~parameter ~doc =
default_arg ~parameter ~doc ~default (tez_parameter parameter)
let tez_param ~name ~desc next =
Cli_entries.param
name
(desc ^ " in \xEA\x9C\xA9\n" ^ tez_format)
(fun _ s ->
match Tez.of_string s with
| None -> fail (Bad_tez_arg (name, s))
| Some tez -> return tez)
(tez_parameter name)
next
let fee_arg =
@ -128,9 +131,9 @@ let max_priority_arg =
arg
~parameter:"-max-priority"
~doc:"Set the max_priority used when looking for baking slot."
(fun _ s ->
try return (int_of_string s)
with _ -> fail (Bad_max_priority s))
(parameter (fun _ s ->
try return (int_of_string s)
with _ -> fail (Bad_max_priority s)))
let free_baking_switch =
switch
@ -142,9 +145,9 @@ let endorsement_delay_arg =
~parameter:"-endorsement-delay"
~doc:"Set the delay used before to endorse the current block."
~default:"15"
(fun _ s ->
try return (int_of_string s)
with _ -> fail (Bad_endorsement_delay s))
(parameter (fun _ s ->
try return (int_of_string s)
with _ -> fail (Bad_endorsement_delay s)))
module Daemon = struct
let baking_switch =

2
src/client/embedded/alpha/client_proto_args.mli
View File

@ -39,3 +39,5 @@ module Daemon : sig
val endorsement_switch: (bool, Client_commands.context) arg
val denunciation_switch: (bool, Client_commands.context) arg
end
val string_parameter : (string, Client_commands.context) Cli_entries.parameter

53
src/client/embedded/alpha/client_proto_contracts.ml
View File

@ -55,37 +55,50 @@ module ContractAlias = struct
find_key cctxt key
| _ -> find cctxt s
let autocomplete cctxt =
Client_keys.Public_key_hash.autocomplete cctxt >>=? fun keys ->
RawContractAlias.autocomplete cctxt >>=? fun contracts ->
return (List.map ((^) "key:") keys @ contracts)
let alias_param ?(name = "name") ?(desc = "existing contract alias") next =
let desc =
desc ^ "\n"
^ "can be an contract alias or a key alias (autodetected in this order)\n\
use 'key:name' to force the later" in
Cli_entries.param ~name ~desc
(fun cctxt p -> get_contract cctxt p)
next
Cli_entries.(
param ~name ~desc
(parameter ~autocomplete:autocomplete
(fun cctxt p -> get_contract cctxt p))
next)
let destination_param ?(name = "dst") ?(desc = "destination contract") next =
let desc =
desc ^ "\n"
^ "can be an alias, a key alias, or a literal (autodetected in this order)\n\
use 'text:literal', 'alias:name', 'key:name' to force" in
Cli_entries.param ~name ~desc
(fun cctxt s ->
begin
match Utils.split ~limit:1 ':' s with
| [ "alias" ; alias ]->
find cctxt alias
| [ "key" ; text ] ->
Client_keys.Public_key_hash.find cctxt text >>=? fun v ->
return (s, Contract.default_contract v)
| _ ->
find cctxt s >>= function
| Ok v -> return v
| Error k_errs ->
ContractEntity.of_source cctxt s >>= function
| Ok v -> return (s, v)
| Error c_errs -> Lwt.return (Error (k_errs @ c_errs))
end)
Cli_entries.(
param ~name ~desc
(parameter
~autocomplete:(fun cctxt ->
autocomplete cctxt >>=? fun list1 ->
Client_keys.Public_key_hash.autocomplete cctxt >>=? fun list2 ->
return (list1 @ list2))
(fun cctxt s ->
begin
match Utils.split ~limit:1 ':' s with
| [ "alias" ; alias ]->
find cctxt alias
| [ "key" ; text ] ->
Client_keys.Public_key_hash.find cctxt text >>=? fun v ->
return (s, Contract.default_contract v)
| _ ->
find cctxt s >>= function
| Ok v -> return v
| Error k_errs ->
ContractEntity.of_source cctxt s >>= function
| Ok v -> return (s, v)
| Error c_errs -> Lwt.return (Error (k_errs @ c_errs))
end)))
next
let name cctxt contract =

1
src/client/embedded/alpha/client_proto_contracts.mli
View File

@ -30,6 +30,7 @@ module ContractAlias : sig
val name:
Client_commands.context ->
Contract.t -> string tzresult Lwt.t
val autocomplete: Client_commands.context -> string list tzresult Lwt.t
end
val list_contracts:

15
src/client/embedded/alpha/client_proto_programs.ml
View File

@ -701,6 +701,9 @@ let group =
{ Cli_entries.name = "programs" ;
title = "Commands for managing the record of known programs" }
let data_parameter =
Cli_entries.parameter (fun _ -> parse_data)
let commands () =
let open Cli_entries in
let show_types_switch =
@ -761,10 +764,10 @@ let commands () =
@@ Program.source_param
@@ prefixes [ "on" ; "storage" ]
@@ Cli_entries.param ~name:"storage" ~desc:"the storage data"
(fun _cctxt data -> parse_data data)
data_parameter
@@ prefixes [ "and" ; "input" ]
@@ Cli_entries.param ~name:"storage" ~desc:"the input data"
(fun _cctxt data -> parse_data data)
data_parameter
@@ stop)
(fun (trace_stack, amount) program storage input cctxt ->
let open Data_encoding in
@ -875,10 +878,10 @@ let commands () =
no_options
(prefixes [ "typecheck" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck"
(fun _cctxt data -> parse_data data)
data_parameter
@@ prefixes [ "against" ; "type" ]
@@ Cli_entries.param ~name:"type" ~desc:"the expected type"
(fun _cctxt data -> parse_data data)
data_parameter
@@ stop)
(fun () data exp_ty cctxt ->
let open Data_encoding in
@ -897,7 +900,7 @@ let commands () =
no_options
(prefixes [ "hash" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
(fun _cctxt data -> parse_data data)
data_parameter
@@ stop)
(fun () data cctxt ->
let open Data_encoding in
@ -918,7 +921,7 @@ let commands () =
no_options
(prefixes [ "hash" ; "and" ; "sign" ; "data" ]
@@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
(fun _cctxt data -> parse_data data)
data_parameter
@@ prefixes [ "for" ]
@@ Client_keys.Secret_key.alias_param
@@ stop)

21
src/client/embedded/genesis/client_proto_main.ml
View File

@ -45,6 +45,11 @@ let mine rpc_config ?timestamp block command fitness seckey =
let signed_blk = Environment.Ed25519.Signature.append seckey blk in
Client_node_rpcs.inject_block rpc_config signed_blk [[]]
let int64_parameter =
(Cli_entries.parameter (fun _ p ->
try return (Int64.of_string p)
with _ -> failwith "Cannot read int64"))
let commands () =
let open Cli_entries in
let args =
@ -52,10 +57,10 @@ let commands () =
(arg
~parameter:"-timestamp"
~doc:"Set the timestamp of the block (and initial time of the chain)"
(fun _ t ->
match (Time.of_notation t) with
| None -> Error_monad.failwith "Could not parse value provided to -timestamp option"
| Some t -> return t)) in
(parameter (fun _ t ->
match (Time.of_notation t) with
| None -> Error_monad.failwith "Could not parse value provided to -timestamp option"
| Some t -> return t))) in
[
command ~desc: "Activate a protocol"
@ -65,9 +70,7 @@ let commands () =
@@ prefixes [ "with" ; "fitness" ]
@@ param ~name:"fitness"
~desc:"Hardcoded fitness of the first block (integer)"
(fun _ p ->
try return (Int64.of_string p)
with _ -> failwith "Cannot read int64")
int64_parameter
@@ prefixes [ "and" ; "key" ]
@@ Client_keys.Secret_key.source_param
~name:"password" ~desc:"Dictator's key"
@ -88,9 +91,7 @@ let commands () =
@@ prefixes [ "with" ; "fitness" ]
@@ param ~name:"fitness"
~desc:"Hardcoded fitness of the first block (integer)"
(fun _ p ->
try return (Int64.of_string p)
with _ -> failwith "Cannot read int64")
int64_parameter
@@ prefixes [ "and" ; "key" ]
@@ Environment.Ed25519.Secret_key.param
~name:"password" ~desc:"Dictator's key"

6
src/client_main.ml
View File

@ -40,8 +40,11 @@ let main () =
Random.self_init () ;
Sodium.Random.stir () ;
Lwt.catch begin fun () ->
let original_args = List.tl (Array.to_list Sys.argv) in
begin
Client_config.parse_config_args Client_commands.default_cfg (List.tl (Array.to_list Sys.argv))
Client_config.parse_config_args
(cctxt Client_commands.default_cfg Client_rpcs.default_config)
original_args
>>=? fun (parsed_config_file, parsed_args, remaining) ->
let rpc_config : Client_rpcs.config = {
Client_rpcs.default_config with
@ -82,6 +85,7 @@ let main () =
in
let client_config = (cctxt config rpc_config) in
(Cli_entries.dispatch
~global_options:Client_config.global_options
commands
client_config
remaining) end >>=

6
src/node/updater/tezos_protocol_environment.ml
View File

@ -59,7 +59,7 @@ module Ed25519 = struct
let of_bytes s = Sodium.Sign.Bytes.to_public_key s
let param ?(name="ed25519-public") ?(desc="Ed25519 public key (b58check-encoded)") t =
Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check str)) t
Cli_entries.(param ~name ~desc (parameter (fun _ str -> Lwt.return (of_b58check str))) t)
let () =
Base58.check_encoded_prefix b58check_encoding "edpk" 54
@ -121,7 +121,7 @@ module Ed25519 = struct
let of_bytes s = Sodium.Sign.Bytes.to_secret_key s
let param ?(name="ed25519-secret") ?(desc="Ed25519 secret key (b58check-encoded)") t =
Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check str)) t
Cli_entries.(param ~name ~desc (parameter (fun _ str -> Lwt.return (of_b58check str))) t)
let () =
Base58.check_encoded_prefix b58check_encoding "edsk" 98
@ -180,7 +180,7 @@ module Ed25519 = struct
let of_bytes s = MBytes.of_string (Bytes.to_string s)
let param ?(name="signature") ?(desc="Signature (b58check-encoded)") t =
Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check str)) t
Cli_entries.(param ~name ~desc (parameter (fun _ str -> Lwt.return (of_b58check str))) t)
let () =
Base58.check_encoded_prefix b58check_encoding "edsig" 99

311
src/utils/cli_entries.ml
View File

@ -19,18 +19,25 @@ type error += Option_expected_argument of string
type error += Unknown_option of string
type error += Invalid_options_combination of string
type ('a, 'arg) arg =
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 ('a, 'ctx) arg =
| Arg : { doc : string ;
parameter : string ;
kind : 'arg -> string -> 'p tzresult Lwt.t } ->
('p option, 'arg) arg
kind : ('p, 'ctx) parameter } ->
('p option, 'ctx) arg
| DefArg : { doc : string ;
parameter : string ;
kind : 'arg -> string -> 'p tzresult Lwt.t ;
default : string } -> ('p, 'arg) arg
kind : ('p, 'ctx) parameter ;
default : string } -> ('p, 'ctx) arg
| Switch : { doc : string ;
parameter : string } ->
(bool, 'arg) arg
(bool, 'ctx) arg
let arg ~doc ~parameter kind =
Arg { doc ;
@ -44,7 +51,7 @@ let default_arg ~doc ~parameter ~default kind =
default }
let switch ~doc ~parameter =
Switch {doc ; parameter}
Switch { doc ; parameter }
type ('a, 'arg) args =
| NoArgs : (unit, 'args) args
@ -55,21 +62,21 @@ let parse_arg :
type a ctx. (a, ctx) arg -> string option StringMap.t -> ctx -> a tzresult Lwt.t =
fun spec args_dict ctx ->
match spec with
| Arg { parameter ; kind } ->
| Arg { parameter ; kind={ converter } } ->
begin
try
begin
match StringMap.find parameter args_dict with
| None -> return None
| Some s ->
(kind ctx s) >>|? fun x ->
(converter ctx s) >>|? fun x ->
Some x
end
with Not_found ->
return None
end
| DefArg { parameter ; kind ; default } ->
kind ctx default >>= fun default ->
| DefArg { parameter ; kind={ converter } ; default } ->
converter ctx default >>= fun default ->
begin match default with
| Ok x -> return x
| Error _ ->
@ -80,7 +87,7 @@ let parse_arg :
begin try
match StringMap.find parameter args_dict with
| None -> return default
| Some s -> kind ctx s
| Some s -> converter ctx s
with Not_found -> return default
end
| Switch { parameter } ->
@ -113,30 +120,37 @@ let rec make_arities_dict :
| Switch { parameter } -> recur parameter 0
end
let check_help_flag error = function
| ("-help" | "--help") :: _ -> fail error
| _ -> return ()
let make_args_dict_consume help_flag spec args =
let rec make_args_dict arities acc args =
(* 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 StringMap.mem arg arities
then let arity = StringMap.find arg arities in
check_help_flag help_flag tl >>=? fun () ->
match arity, tl with
| 0, tl' -> make_args_dict arities (StringMap.add arg None acc) tl'
| 0, tl' -> make_args_dict completing arities (StringMap.add arg None acc) tl'
| 1, value :: tl' ->
make_args_dict arities (StringMap.add arg (Some value) acc) tl'
make_args_dict completing arities (StringMap.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 (make_arities_dict StringMap.empty spec) StringMap.empty args
in make_args_dict false (make_arities_dict StringMap.empty spec) StringMap.empty args
let make_args_dict_filter help_flag spec args =
let rec make_args_dict arities (dict, other_args) args =
@ -161,7 +175,7 @@ let make_args_dict_filter help_flag spec args =
(dict, List.rev remaining)
let make_args_dict help_handler spec args =
make_args_dict_consume help_handler spec args >>=? fun (args, remaining) ->
make_args_dict_consume help_handler false spec args >>=? fun (args, remaining) ->
match remaining with
| [] -> return args
| hd :: _ -> fail (Unknown_option hd)
@ -210,18 +224,18 @@ let args10 spec1 spec2 spec3 spec4 spec5 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, 'arg, 'ret) params =
| Prefix : string * ('a, 'arg, 'ret) params ->
('a, 'arg, 'ret) params
type ('a, 'ctx, 'ret) params =
| Prefix : string * ('a, 'ctx, 'ret) params ->
('a, 'ctx, 'ret) params
| Param : string * string *
('arg -> string -> 'p tzresult Lwt.t) *
('a, 'arg, 'ret) params ->
('p -> 'a, 'arg, 'ret) params
('p, 'ctx) parameter *
('a, 'ctx, 'ret) params ->
('p -> 'a, 'ctx, 'ret) params
| Stop :
('arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params
('ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params
| Seq : string * string *
('arg -> string -> 'p tzresult Lwt.t) ->
('p list -> 'arg -> 'ret tzresult Lwt.t, 'arg, 'ret) params
('p, 'ctx) parameter ->
('p list -> 'ctx -> 'ret tzresult Lwt.t, 'ctx, 'ret) params
(* A command group *)
type group =
@ -244,11 +258,12 @@ 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 * bool * bool -> 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 spec args >>=? fun (dict, remaining) ->
make_args_dict_consume Bare_help true spec args >>=? fun (dict, remaining) ->
parse_args spec dict ctx >>|? fun nested ->
(converter nested, remaining)
@ -257,7 +272,7 @@ let param ~name ~desc kind next = Param (name, desc, kind, next)
let seq ~name ~desc kind = Seq (name, desc, kind)
let seq_of_param param =
match param Stop with
| Param (n, desc, f, Stop) -> Seq (n, desc, f)
| Param (n, desc, parameter, Stop) -> Seq (n, desc, parameter)
| _ -> invalid_arg "Cli_entries.seq_of_param"
let prefix keyword next = Prefix (keyword, next)
@ -272,7 +287,7 @@ let command ?group ~desc options params handler =
(* Param combinators *)
let string ~name ~desc next =
param name desc (fun _ s -> return s) next
param name desc { converter=(fun _ s -> return s) ; autocomplete=None } next
(* Help commands *)
let help_group =
@ -330,22 +345,22 @@ let rec help_commands commands =
(* Command execution *)
let exec
(type arg) (type ret)
(type ctx) (type ret)
(Command { options=(Argument { converter ; spec=options_spec }) ;
params=spec ;
handler })
(ctx : arg) params args_dict =
(ctx : ctx) params args_dict =
let rec exec
: type a. int -> (a, arg, ret) params -> a -> string list -> ret tzresult Lwt.t
: type a. int -> (a, ctx, ret) params -> a -> string list -> ret tzresult Lwt.t
= fun i spec cb params ->
match spec, params with
| Stop, _ -> cb ctx
| Seq (_, _, f), seq ->
| Seq (_, _, { converter }), seq ->
let rec do_seq i acc = function
| [] -> return (List.rev acc)
| p :: rest ->
Lwt.catch
(fun () -> f ctx p)
(fun () -> converter ctx p)
(function
| Failure msg -> Error_monad.failwith "%s" msg
| exn -> fail (Exn exn))
@ -355,9 +370,9 @@ let exec
cb parsed ctx
| Prefix (n, next), p :: rest when n = p ->
exec (succ i) next cb rest
| Param (_, _, f, next), p :: rest ->
| Param (_, _, { converter }, next), p :: rest ->
Lwt.catch
(fun () -> f ctx p)
(fun () -> converter ctx p)
(function
| Failure msg -> Error_monad.failwith "%s" msg
| exn -> fail (Exn exn))
@ -374,13 +389,14 @@ type ('arg, 'ret) level =
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 ('arg, 'ret) tree =
| TPrefix : ('arg, 'ret) level -> ('arg, 'ret) tree
| TParam : ('arg, 'ret) param_level -> ('arg, 'ret) tree
| TStop : ('arg, 'ret) command -> ('arg, 'ret) tree
| TSeq : ('arg, 'ret) command -> ('arg, 'ret) tree
| TEmpty : ('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 } }) ->
@ -390,20 +406,25 @@ let has_options : type ret ctx. (ctx, ret) command -> bool =
in args_help spec
let insert_in_dispatch_tree
(type arg) (type ret)
(type ctx) (type ret)
root (Command { params } as command) =
let access_autocomplete :
type p. (p, ctx) parameter -> (ctx -> string list tzresult Lwt.t) option =
fun { autocomplete } -> autocomplete in
let rec insert_tree
: type a. (arg, ret) tree -> (a, arg, ret) params -> (_, _) tree
: type a. (ctx, ret) tree -> (a, ctx, ret) params -> (ctx, ret) tree
= fun t c -> match t, c with
| TEmpty, Stop -> TStop command
| TEmpty, Seq (_, _, _) -> TSeq command
| TEmpty, Param (_, _, _, next) ->
TParam { tree = insert_tree TEmpty next ; stop = None }
| TEmpty, Seq (_, _, { autocomplete }) -> TSeq (command, autocomplete)
| TEmpty, Param (_, _, param, next) ->
TParam { tree = insert_tree TEmpty next ; stop = None ; autocomplete=access_autocomplete param}
| TEmpty, Prefix (n, next) ->
TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] }
| TStop cmd, Param (_, _, _, next) ->
| TStop cmd, Param (_, _, param, next) ->
if not (has_options cmd)
then TParam { tree = insert_tree TEmpty next ; stop = Some cmd }
then TParam { tree = insert_tree TEmpty next ;
stop = Some cmd ;
autocomplete=access_autocomplete param }
else raise (Failure "Command cannot have both prefix and options")
| TStop cmd, Prefix (n, next) ->
TPrefix { stop = Some cmd ;
@ -431,7 +452,7 @@ let make_dispatch_tree commands =
let rec gather_commands ?(acc=[]) tree =
match tree with
| TEmpty -> acc
| TSeq c
| TSeq (c, _)
| TStop c -> c :: acc
| TPrefix { stop ; prefix } ->
gather_assoc ~acc:(match stop with
@ -459,7 +480,7 @@ let find_command tree initial_arguments =
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 ->
| 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
@ -553,7 +574,7 @@ let print_highlight highlight_strings formatter str =
Format.fprintf formatter "\x1b[103m%s\x1b[0m" delimiter)
list
end
in print_string (List.map Str.regexp highlight_strings)
in print_string (List.map Str.regexp_string highlight_strings)
let print_commandline ppf (highlights, options, args) =
let rec print
@ -716,6 +737,168 @@ let command_usage
commands
exe
let get_arg : type a ctx. (a, ctx) arg -> string = function
| Arg { parameter } -> parameter
| DefArg { parameter } -> parameter
| Switch { parameter } -> parameter
let rec list_args : type arg ctx. (arg, ctx) args -> string list = function
| NoArgs -> []
| AddArg (arg, args) -> (get_arg arg) :: (list_args args)
let complete_func autocomplete cctxt =
match autocomplete with
| None -> return []
| Some autocomplete -> autocomplete cctxt
let list_command_args (Command { options=Argument { spec } }) =
list_args spec
module StringSet = Set.Make(String)
let get_arg_parameter (type a) (arg : (a, _) arg) =
match arg with
| Arg { parameter } -> parameter
| DefArg { parameter } -> parameter
| Switch { parameter } -> parameter
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 []
let rec remaining_spec :
type a ctx. StringSet.t -> (a, ctx) args -> string list =
fun seen -> function
| NoArgs -> []
| AddArg (arg, rest) ->
let parameter = get_arg_parameter arg in
if StringSet.mem parameter seen
then (remaining_spec seen rest)
else parameter :: (remaining_spec seen rest)
let complete_options (type ctx) continuation args args_spec ind (ctx : ctx) =
let arities = make_arities_dict StringMap.empty args_spec in
let rec complete_spec : type a. string -> (a, ctx) args -> string list tzresult Lwt.t =
fun name -> function
| NoArgs -> return []
| AddArg (arg, rest) ->
if (get_arg_parameter arg) = 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 StringMap.mem arg arities
then
let seen = StringSet.add arg seen in
begin
match StringMap.find arg arities, 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"
end
else continuation args ind
in help args ind StringSet.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 []
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 []
end
| TParam { tree }, _ :: tl ->
help tree tl (ind - 1)
| TStop Command { options=Argument { spec } }, args ->
complete_options (fun _ _ -> return []) args spec ind cctxt
| (TParam _ | TPrefix _), []
| 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 rec ind n = function
| [] -> None
| hd :: tl ->
if hd = prev_arg
then Some (Utils.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
match global_options with
| None -> command_completions
| Some (Argument { spec }) ->
remaining_spec StringSet.empty spec
@ command_completions
end
else
match ind 0 args with
| 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
end
end >>|? fun completions ->
List.filter
(fun completion -> Str.string_match (Str.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 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 _ -> []))
| _ ->
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
@ -789,6 +972,13 @@ let handle_cli_errors ~stdout ~stderr ~global_options = function
Format.fprintf stdout "%a@."
(usage ~global_options ~details:true ?highlights:None) [] ;
return 0
| Autocomplete_command (completions) ->
Format.pp_print_list
~pp_sep:Format.pp_print_newline
Format.pp_print_string
Format.std_formatter
completions;
return 0
| Help_flag commands ->
Format.fprintf stdout "%a@." command_usage commands ;
return 0
@ -796,19 +986,6 @@ let handle_cli_errors ~stdout ~stderr ~global_options = function
end
| (Error _) as errors -> Lwt.return errors
(* Try a list of commands on a list of arguments *)
let dispatch commands ctx args =
let commands = help_commands commands @ commands in
match args with
| [] | [ "-help" | "--help" ] -> fail Bare_help
| _ ->
let tree = make_dispatch_tree commands in
find_command tree args >>=? fun (command, args_dict, filtered_args) ->
exec command ctx filtered_args args_dict
let usage ppf ?global_options commands =
usage ppf ?highlights:None ~details:true ?global_options commands
let () =
register_error_kind
`Branch

29
src/utils/cli_entries.mli
View File

@ -12,6 +12,12 @@ open Error_monad
(* Tezos: a small Command Line Parsing library *)
(* Only used in the client. *)
(** The type for positional parameters and flags *)
type ('p, 'ctx) parameter
val parameter : ?autocomplete:('ctx -> string list tzresult Lwt.t) ->
('ctx -> string -> 'p tzresult Lwt.t) ->
('p, 'ctx) parameter
(** {2 Flags and Options } *)
(** {3 Options and Switches } *)
@ -22,13 +28,14 @@ type ('a, 'ctx) arg
The [~parameter] argument should begin with a [-].
If the argument is not provided, [None] is returned *)
val arg : doc:string -> parameter:string ->
('ctx -> string -> 'p tzresult Lwt.t) ->
('p, 'ctx) parameter ->
('p option, 'ctx) arg
(** Create an argument that will contain the [~default] value if it is not provided.
@see arg *)
val default_arg : doc:string -> parameter:string ->
default:string ->
('ctx -> string -> 'p tzresult Lwt.t) ->
('p, 'ctx) parameter ->
('p, 'ctx) arg
(** Create a boolean switch.
The value will be set to [true] if the switch is provided and [false] if it is not. *)
@ -46,21 +53,25 @@ type ('a, 'ctx) options
(** Include no optional parameters *)
val no_options : (unit, 'ctx) options
(** Include 1 optional parameter *)
val args1 :
('a, 'ctx) arg ->
('a, 'ctx) options
(** Include 2 optional parameters *)
val args2 :
('a, 'ctx) arg ->
('b, 'ctx) arg ->
('a * 'b, 'ctx) options
(** Include 3 optional parameters *)
val args3 :
('a, 'ctx) arg ->
('b, 'ctx) arg ->
('c, 'ctx) arg ->
('a * 'b * 'c, 'ctx) options
(** Include 4 optional parameters *)
val args4 :
('a, 'ctx) arg ->
@ -68,6 +79,7 @@ val args4 :
('c, 'ctx) arg ->
('d, 'ctx) arg ->
('a * 'b * 'c * 'd, 'ctx) options
(** Include 5 optional parameters *)
val args5 :
('a, 'ctx) arg ->
@ -76,6 +88,7 @@ val args5 :
('d, 'ctx) arg ->
('e, 'ctx) arg ->
('a * 'b * 'c * 'd * 'e, 'ctx) options
(** Include 6 optional parameters *)
val args6 :
('a, 'ctx) arg ->
@ -85,6 +98,7 @@ val args6 :
('e, 'ctx) arg ->
('f, 'ctx) arg ->
('a * 'b * 'c * 'd * 'e * 'f, 'ctx) options
(** Include 7 optional parameters *)
val args7 :
('a, 'ctx) arg ->
@ -93,15 +107,18 @@ val args7 :
('d, 'ctx) arg ->
('e, 'ctx) arg -> ('f, 'ctx) arg -> ('g, 'ctx) arg ->
('a * 'b * 'c * 'd * 'e * 'f * 'g, 'ctx) options
(** Include 8 optional parameters *)
val args8 : ('a, 'ctx) arg -> ('b, 'ctx) arg -> ('c, 'ctx) arg -> ('d, 'ctx) arg ->
('e, 'ctx) arg -> ('f, 'ctx) arg -> ('g, 'ctx) arg -> ('h, 'ctx) arg ->
('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h, 'ctx) options
(** Include 9 optional parameters *)
val args9 : ('a, 'ctx) arg -> ('b, 'ctx) arg -> ('c, 'ctx) arg -> ('d, 'ctx) arg ->
('e, 'ctx) arg -> ('f, 'ctx) arg -> ('g, 'ctx) arg -> ('h, 'ctx) arg ->
('i, 'ctx) arg ->
('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i, 'ctx) options
(** Include 10 optional parameters *)
val args10 : ('a, 'ctx) arg -> ('b, 'ctx) arg -> ('c, 'ctx) arg -> ('d, 'ctx) arg ->
('e, 'ctx) arg -> ('f, 'ctx) arg -> ('g, 'ctx) arg -> ('h, 'ctx) arg ->
@ -117,7 +134,7 @@ type ('a, 'ctx, 'ret) params
val param:
name: string ->
desc: string ->
('ctx -> string -> 'a tzresult Lwt.t) ->
('a, 'ctx) parameter ->
('b, 'ctx, 'ret) params ->
('a -> 'b, 'ctx, 'ret) params
@ -189,7 +206,11 @@ val handle_cli_errors:
(** Find and call the applicable command on the series of arguments.
@raises [Failure] if the command list would be ambiguous. *)
val dispatch:
('ctx, 'ret) command list -> 'ctx -> string list -> 'ret tzresult Lwt.t
?global_options:('a, 'ctx) options ->
('ctx, 'ret) command list ->
'ctx ->
string list ->
'ret tzresult Lwt.t
(** Parse the sequence of optional arguments that proceed a command *)
val parse_initial_options :

6
src/utils/hash.ml
View File

@ -313,7 +313,9 @@ module Make_Blake2B (R : sig
conv to_b58check (Data_encoding.Json.wrap_error of_b58check_exn) string)
let param ?(name=K.name) ?(desc=K.title) t =
Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check str)) t
Cli_entries.param
~name
~desc (Cli_entries.parameter (fun _ str -> Lwt.return (of_b58check str))) t
let pp ppf t =
Format.pp_print_string ppf (to_b58check t)
@ -619,7 +621,7 @@ module Net_id = struct
conv to_b58check (Data_encoding.Json.wrap_error of_b58check_exn) string)
let param ?(name=name) ?(desc=title) t =
Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b58check str)) t
Cli_entries.(param ~name ~desc (parameter (fun _ str -> Lwt.return (of_b58check str))) t)
let pp ppf t =
Format.pp_print_string ppf (to_b58check t)