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

Clic: minor internal types cleanup

Browse Source
This commit is contained in:
Benjamin Canou 2018-07-20 21:19:23 +02:00 committed by Pierre Boutillier
parent 09bf4e4819
commit 5167f7b298
No known key found for this signature in database
GPG Key ID: C2F73508B56A193C
1 changed files with 46 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
src/lib_clic/clic.ml
View File

@ -32,19 +32,23 @@ type ('p, 'ctx) parameter =
let parameter ?autocomplete converter = let parameter ?autocomplete converter =
{ converter ; autocomplete } { converter ; autocomplete }
type label =
{ long : string ;
short : char option }
type ('a, 'ctx) arg = type ('a, 'ctx) arg =
| Arg : { doc : string ; | Arg : { doc : string ;
parameter : string * char option ; label : label ;
placeholder : string ; placeholder : string ;
kind : ('p, 'ctx) parameter } -> kind : ('p, 'ctx) parameter } ->
('p option, 'ctx) arg ('p option, 'ctx) arg
| DefArg : { doc : string ; | DefArg : { doc : string ;
parameter : string * char option ; label : label ;
placeholder : string ; placeholder : string ;
kind : ('p, 'ctx) parameter ; kind : ('p, 'ctx) parameter ;
default : string } -> ('p, 'ctx) arg default : string } -> ('p, 'ctx) arg
| Switch : { doc : string ; | Switch : { label : label ;
parameter : string * char option } -> doc : string } ->
(bool, 'ctx) arg (bool, 'ctx) arg
| Constant : 'a -> ('a, 'ctx) arg | Constant : 'a -> ('a, 'ctx) arg
@ -114,24 +118,24 @@ let print_desc ppf doc =
| Some doc -> | Some doc ->
Format.fprintf ppf "%s@{<full>@\n @[<hov 0>%a@]@}" short Format.pp_print_text doc Format.fprintf ppf "%s@{<full>@\n @[<hov 0>%a@]@}" short Format.pp_print_text doc
let print_parameter ppf = function let print_label ppf = function
| long, None -> Format.fprintf ppf "--%s" long | { long ; short = None } -> Format.fprintf ppf "--%s" long
| long, Some short -> Format.fprintf ppf "-%c --%s" short long | { long ; short = Some short } -> Format.fprintf ppf "-%c --%s" short long
let print_options_detailed (type ctx) = let print_options_detailed (type ctx) =
let help_option : type a.Format.formatter -> (a, ctx) arg -> unit = let help_option : type a.Format.formatter -> (a, ctx) arg -> unit =
fun ppf -> function fun ppf -> function
| Arg { parameter ; placeholder ; doc ; _ } -> | Arg { label ; placeholder ; doc ; _ } ->
Format.fprintf ppf "@{<opt>%a <%s>@}: %a" Format.fprintf ppf "@{<opt>%a <%s>@}: %a"
print_parameter parameter placeholder print_label label placeholder
print_desc doc ; print_desc doc ;
| DefArg { parameter ; placeholder ; doc ; default ; _ } -> | DefArg { label ; placeholder ; doc ; default ; _ } ->
Format.fprintf ppf "@{<opt>%a <%s>@}: %a" Format.fprintf ppf "@{<opt>%a <%s>@}: %a"
print_parameter parameter placeholder print_label label placeholder
print_desc (doc ^ "\nDefaults to `" ^ default ^ "`.") print_desc (doc ^ "\nDefaults to `" ^ default ^ "`.")
| Switch { parameter ; doc } -> | Switch { label ; doc } ->
Format.fprintf ppf "@{<opt>%a@}: %a" Format.fprintf ppf "@{<opt>%a@}: %a"
print_parameter parameter print_label label
print_desc doc print_desc doc
| Constant _ -> () in | Constant _ -> () in
let rec help : type b. Format.formatter -> (b, ctx) args -> unit = let rec help : type b. Format.formatter -> (b, ctx) args -> unit =
@ -153,15 +157,15 @@ let print_options_brief (type ctx) =
let help_option : let help_option :
type a. Format.formatter -> (a, ctx) arg -> unit = type a. Format.formatter -> (a, ctx) arg -> unit =
fun ppf -> function fun ppf -> function
| DefArg { parameter ; placeholder ; _ } -> | DefArg { label ; placeholder ; _ } ->
Format.fprintf ppf "[@{<opt>%a <%s>@}]" Format.fprintf ppf "[@{<opt>%a <%s>@}]"
print_parameter parameter placeholder print_label label placeholder
| Arg { parameter ; placeholder ; _ } -> | Arg { label ; placeholder ; _ } ->
Format.fprintf ppf "[@{<opt>%a <%s>@}]" Format.fprintf ppf "[@{<opt>%a <%s>@}]"
print_parameter parameter placeholder print_label label placeholder
| Switch { parameter ; _ } -> | Switch { label ; _ } ->
Format.fprintf ppf "[@{<opt>%a@}]" Format.fprintf ppf "[@{<opt>%a@}]"
print_parameter parameter print_label label
| Constant _ -> () | Constant _ -> ()
in let rec help : type b. Format.formatter -> (b, ctx) args -> unit = in let rec help : type b. Format.formatter -> (b, ctx) args -> unit =
fun ppf -> function fun ppf -> function
@ -558,25 +562,25 @@ let constant c = Constant c
let arg ~doc ?short ~long ~placeholder kind = let arg ~doc ?short ~long ~placeholder kind =
Arg { doc ; Arg { doc ;
parameter = (long, short) ; label = { long ; short } ;
placeholder ; placeholder ;
kind } kind }
let default_arg ~doc ?short ~long ~placeholder ~default kind = let default_arg ~doc ?short ~long ~placeholder ~default kind =
DefArg { doc ; DefArg { doc ;
placeholder ; placeholder ;
parameter = (long, short) ; label = { long ; short } ;
kind ; kind ;
default } default }
let switch ~doc ?short ~long () = let switch ~doc ?short ~long () =
Switch { doc ; parameter = (long, short) } Switch { doc ; label = { long ; short } }
let parse_arg : let parse_arg :
type a ctx. ?command:_ command -> (a, ctx) arg -> string list TzString.Map.t -> ctx -> a tzresult Lwt.t = type a ctx. ?command:_ command -> (a, ctx) arg -> string list TzString.Map.t -> ctx -> a tzresult Lwt.t =
fun ?command spec args_dict ctx -> fun ?command spec args_dict ctx ->
match spec with match spec with
| Arg { parameter = (long, _) ; kind = { converter ; _ } ; _ } -> | Arg { label = { long ; short = _ } ; kind = { converter ; _ } ; _ } ->
begin match TzString.Map.find_opt long args_dict with begin match TzString.Map.find_opt long args_dict with
| None | None
| Some [] -> return_none | Some [] -> return_none
@ -588,7 +592,7 @@ let parse_arg :
| Some (_ :: _) -> | Some (_ :: _) ->
fail (Multiple_occurences ("--" ^ long, command)) fail (Multiple_occurences ("--" ^ long, command))
end end
| DefArg { parameter = (long, _) ; kind = { converter ; _ } ; default ; _ } -> | DefArg { label = { long ; short = _ } ; kind = { converter ; _ } ; default ; _ } ->
converter ctx default >>= fun default -> converter ctx default >>= fun default ->
begin match default with begin match default with
| Ok x -> return x | Ok x -> return x
@ -607,7 +611,7 @@ let parse_arg :
| Some (_ :: _) -> | Some (_ :: _) ->
fail (Multiple_occurences (long, command)) fail (Multiple_occurences (long, command))
end end
| Switch { parameter = (long, _) ; _ } -> | Switch { label = { long ; short = _ } ; _ } ->
begin match TzString.Map.find_opt long args_dict with begin match TzString.Map.find_opt long args_dict with
| None | None
| Some [] -> return_false | Some [] -> return_false
@ -634,7 +638,7 @@ let rec make_arities_dict :
fun args acc -> match args with fun args acc -> match args with
| NoArgs -> acc | NoArgs -> acc
| AddArg (arg, rest) -> | AddArg (arg, rest) ->
let recur (long, short) num = let recur { long ; short } num =
(match short with (match short with
| None -> acc | None -> acc
| Some c -> TzString.Map.add ("-" ^ String.make 1 c) (num, long) acc) |> | Some c -> TzString.Map.add ("-" ^ String.make 1 c) (num, long) acc) |>
@ -642,15 +646,15 @@ let rec make_arities_dict :
TzString.Map.add ("--" ^ long) (num, long) |> TzString.Map.add ("--" ^ long) (num, long) |>
make_arities_dict rest in make_arities_dict rest in
match arg with match arg with
| Arg { parameter ; _ } -> recur parameter 1 | Arg { label ; _ } -> recur label 1
| DefArg { parameter ; _ } -> recur parameter 1 | DefArg { label ; _ } -> recur label 1
| Switch { parameter ; _ } -> recur parameter 0 | Switch { label ; _ } -> recur label 0
| Constant _c -> make_arities_dict rest acc | Constant _c -> make_arities_dict rest acc
type error += Help : 'a command option -> error type error += Help : 'a command option -> error
let check_help_flag ?command = function let check_help_flag ?command = function
| ("-help" | "--help") :: _ -> fail (Help command) | ("-h" | "--help") :: _ -> fail (Help command)
| _ -> return_unit | _ -> return_unit
let add_occurrence long value acc = let add_occurrence long value acc =
@ -934,7 +938,7 @@ let find_command tree initial_arguments =
match tree, arguments with match tree, arguments with
| (TStop _ | TSeq _ | (TStop _ | TSeq _
| TPrefix { stop = Some _ ; _ } | TPrefix { stop = Some _ ; _ }
| TParam { stop = Some _ ; _}), ("-help" | "--help") :: _ -> | TParam { stop = Some _ ; _}), ("-h" | "--help") :: _ ->
begin match gather_commands tree with begin match gather_commands tree with
| [] -> assert false | [] -> assert false
| [ command ] -> fail (Help (Some command)) | [ command ] -> fail (Help (Some command))
@ -952,14 +956,14 @@ let find_command tree initial_arguments =
fail (Extra_arguments (unparsed, command)) fail (Extra_arguments (unparsed, command))
end end
| TSeq (Command { options = Argument { spec ; _ } ; _ } as command, _), remaining -> | TSeq (Command { options = Argument { spec ; _ } ; _ } as command, _), remaining ->
if List.exists (function "-help" | "--help" -> true | _ -> false) remaining then if List.exists (function "-h" | "--help" -> true | _ -> false) remaining then
fail (Help (Some command)) fail (Help (Some command))
else else
make_args_dict_filter ~command spec remaining >>|? fun (dict, remaining) -> make_args_dict_filter ~command spec remaining >>|? fun (dict, remaining) ->
(command, dict, List.rev_append acc remaining) (command, dict, List.rev_append acc remaining)
| TPrefix { stop = Some cmd ; _ }, [] -> | TPrefix { stop = Some cmd ; _ }, [] ->
return (cmd, empty_args_dict, initial_arguments) return (cmd, empty_args_dict, initial_arguments)
| TPrefix { stop = None ; prefix }, ([] | ("-help" | "--help") :: _) -> | TPrefix { stop = None ; prefix }, ([] | ("-h" | "--help") :: _) ->
fail (Unterminated_command (initial_arguments, gather_assoc prefix)) fail (Unterminated_command (initial_arguments, gather_assoc prefix))
| TPrefix { prefix ; _ }, hd_arg :: tl -> | TPrefix { prefix ; _ }, hd_arg :: tl ->
begin begin
@ -968,7 +972,7 @@ let find_command tree initial_arguments =
with Not_found -> fail (Command_not_found (List.rev acc, gather_assoc prefix)) with Not_found -> fail (Command_not_found (List.rev acc, gather_assoc prefix))
end >>=? fun tree' -> end >>=? fun tree' ->
traverse tree' tl (hd_arg :: acc) traverse tree' tl (hd_arg :: acc)
| TParam { stop = None ; _ }, ([] | ("-help" | "--help") :: _) -> | TParam { stop = None ; _ }, ([] | ("-h" | "--help") :: _) ->
fail (Unterminated_command (initial_arguments, gather_commands tree)) fail (Unterminated_command (initial_arguments, gather_commands tree))
| TParam { stop = Some c ; _ }, [] -> | TParam { stop = Some c ; _ }, [] ->
return (c, empty_args_dict, initial_arguments) return (c, empty_args_dict, initial_arguments)
@ -979,17 +983,17 @@ let find_command tree initial_arguments =
in traverse tree initial_arguments [] in traverse tree initial_arguments []
let get_arg_parameter (type a) (arg : (a, _) arg) = let get_arg_label (type a) (arg : (a, _) arg) =
match arg with match arg with
| Arg { parameter ; _ } -> parameter | Arg { label ; _ } -> label
| DefArg { parameter ; _ } -> parameter | DefArg { label ; _ } -> label
| Switch { parameter ; _ } -> parameter | Switch { label ; _ } -> label
| Constant _ -> assert false | Constant _ -> assert false
let get_arg let get_arg
: type a ctx. (a, ctx) arg -> string list : type a ctx. (a, ctx) arg -> string list
= fun arg -> = fun arg ->
let long, short = get_arg_parameter arg in let { long ; short } = get_arg_label arg in
("--" ^ long) :: match short with None -> [] | Some c -> [ "-" ^ String.make 1 c ] ("--" ^ long) :: match short with None -> [] | Some c -> [ "-" ^ String.make 1 c ]
let rec list_args : type arg ctx. (arg, ctx) args -> string list = function let rec list_args : type arg ctx. (arg, ctx) args -> string list = function
@ -1019,7 +1023,7 @@ let rec remaining_spec :
| AddArg (Constant _, rest) -> | AddArg (Constant _, rest) ->
remaining_spec seen rest remaining_spec seen rest
| AddArg (arg, rest) -> | AddArg (arg, rest) ->
let (long, _) = get_arg_parameter arg in let { long ; _ } = get_arg_label arg in
if TzString.Set.mem long seen if TzString.Set.mem long seen
then remaining_spec seen rest then remaining_spec seen rest
else get_arg arg @ remaining_spec seen rest else get_arg arg @ remaining_spec seen rest
@ -1032,7 +1036,7 @@ let complete_options (type ctx) continuation args args_spec ind (ctx : ctx) =
| AddArg (Constant _, rest) -> | AddArg (Constant _, rest) ->
complete_spec name rest complete_spec name rest
| AddArg (arg, rest) -> | AddArg (arg, rest) ->
if fst (get_arg_parameter arg) = name if (get_arg_label arg).long = name
then complete_arg ctx arg then complete_arg ctx arg
else complete_spec name rest in else complete_spec name rest in
let rec help args ind seen = let rec help args ind seen =
@ -1134,7 +1138,7 @@ let parse_global_options global_options ctx args =
let dispatch commands ctx args = let dispatch commands ctx args =
let tree = make_dispatch_tree commands in let tree = make_dispatch_tree commands in
match args with match args with
| [] | [ "-help" | "--help" ] -> | [] | [ "-h" | "--help" ] ->
fail (Help None) fail (Help None)
| _ -> | _ ->
find_command tree args >>=? fun (command, args_dict, filtered_args) -> find_command tree args >>=? fun (command, args_dict, filtered_args) ->