Client: add Cli_entries.map_command

This commit is contained in:
Grégoire Henry 2018-02-11 19:17:39 +01:00
parent 0bd31b0c38
commit 29e1735115
2 changed files with 73 additions and 56 deletions

View File

@ -184,6 +184,7 @@ let make_args_dict help_handler spec args =
type (_, _) options = type (_, _) options =
Argument : { spec : ('a, 'arg) args ; Argument : { spec : ('a, 'arg) args ;
converter : 'a -> 'b } -> ('b, 'arg) options converter : 'a -> 'b } -> ('b, 'arg) options
let (>>) arg1 arg2 = AddArg (arg1, arg2) let (>>) arg1 arg2 = AddArg (arg1, arg2)
let args1 spec = let args1 spec =
Argument { spec = spec >> NoArgs; Argument { spec = spec >> NoArgs;
@ -246,12 +247,12 @@ type group =
(* A command wraps a callback with its type and info *) (* A command wraps a callback with its type and info *)
type ('arg, 'ret) command = type ('arg, 'ret) command =
| Command | Command
: { params : ('a, 'arg, 'ret) params ; : { params : ('a, 'iarg, 'ret) params ;
options : ('b, 'arg) options ; options : ('b, 'iarg) options ;
handler : 'b -> 'a ; handler : 'b -> 'a ;
desc : string ; desc : string ;
group : group option } group : group option ;
-> ('arg, 'ret) command conv : 'arg -> 'iarg } -> ('arg, 'ret) command
type format = [ `Plain | `Ansi | `Html ] type format = [ `Plain | `Ansi | `Html ]
@ -285,7 +286,7 @@ let rec prefixes p next =
let stop = Stop let stop = Stop
let no_options = Argument { spec=NoArgs ; converter=fun () -> () } let no_options = Argument { spec=NoArgs ; converter=fun () -> () }
let command ?group ~desc options params handler = let command ?group ~desc options params handler =
Command { params ; options ; handler ; desc ; group } Command { params ; options ; handler ; desc ; group ; conv = (fun x -> x) }
(* Param combinators *) (* Param combinators *)
let string ~name ~desc next = let string ~name ~desc next =
@ -371,16 +372,18 @@ let rec help_commands commands =
fail (Help_cmd (keywords, commands, format, verbosity))) ] fail (Help_cmd (keywords, commands, format, verbosity))) ]
(* Command execution *) (* Command execution *)
let exec let exec
(type ctx) (type ret) (type ctx)
(Command { options = (Argument { converter ; spec = options_spec }) ; (Command { options = (Argument { converter ; spec = options_spec }) ;
params = spec ; params = spec ;
handler ; handler ;
conv ;
_ }) _ })
(ctx : ctx) params args_dict = (ctx : ctx) params args_dict =
let rec exec let rec exec
: type a. int -> (a, ctx, ret) params -> a -> string list -> ret tzresult Lwt.t : type a ctx ret. int -> ctx -> (a, ctx, ret) params -> a -> string list -> ret tzresult Lwt.t
= fun i spec cb params -> = fun i ctx spec cb params ->
match spec, params with match spec, params with
| Stop, _ -> cb ctx | Stop, _ -> cb ctx
| Seq (_, _, { converter ; _ }), seq -> | Seq (_, _, { converter ; _ }), seq ->
@ -397,7 +400,7 @@ let exec
do_seq i [] seq >>=? fun parsed -> do_seq i [] seq >>=? fun parsed ->
cb parsed ctx cb parsed ctx
| Prefix (n, next), p :: rest when n = p -> | Prefix (n, next), p :: rest when n = p ->
exec (succ i) next cb rest exec (succ i) ctx next cb rest
| Param (_, _, { converter ; _ }, next), p :: rest -> | Param (_, _, { converter ; _ }, next), p :: rest ->
Lwt.catch Lwt.catch
(fun () -> converter ctx p) (fun () -> converter ctx p)
@ -405,11 +408,11 @@ let exec
| Failure msg -> Error_monad.failwith "%s" msg | Failure msg -> Error_monad.failwith "%s" msg
| exn -> fail (Exn exn)) | exn -> fail (Exn exn))
|> trace (Bad_argument (i, p)) >>=? fun v -> |> trace (Bad_argument (i, p)) >>=? fun v ->
exec (succ i) next (cb v) rest exec (succ i) ctx next (cb v) rest
| _ -> raise (Failure ("cli_entries internal error: exec no case matched")) | _ -> raise (Failure ("cli_entries internal error: exec no case matched")) in
in let ctx = conv ctx in
parse_args options_spec args_dict ctx >>=? fun parsed_options -> parse_args options_spec args_dict ctx >>=? fun parsed_options ->
exec 1 spec (handler (converter parsed_options)) params exec 1 ctx spec (handler (converter parsed_options)) params
(* Command dispatch tree *) (* Command dispatch tree *)
type ('arg, 'ret) level = type ('arg, 'ret) level =
@ -428,51 +431,60 @@ and ('ctx, 'ret) tree =
let has_options : type ret ctx. (ctx, ret) command -> bool = let has_options : type ret ctx. (ctx, ret) command -> bool =
fun (Command { options = Argument { spec ; _ } ; _ }) -> fun (Command { options = Argument { spec ; _ } ; _ }) ->
let args_help : type a. (a, ctx) args -> bool = function let args_help : type a. (a, _) args -> bool = function
| NoArgs -> false | NoArgs -> false
| AddArg (_, _) -> true | AddArg (_, _) -> true
in args_help spec in args_help spec
let insert_in_dispatch_tree let insert_in_dispatch_tree :
(type ctx) (type ret) type ctx ret. (ctx, ret) tree -> (ctx, ret) command -> (ctx, ret) tree =
root (Command { params ; _ } as command) = fun root (Command { params ; conv ; _ } as command) ->
let access_autocomplete : let access_autocomplete :
type p. (p, ctx) parameter -> (ctx -> string list tzresult Lwt.t) option = type p ctx. (p, ctx) parameter -> (ctx -> string list tzresult Lwt.t) option =
fun { autocomplete ; _ } -> autocomplete in fun { autocomplete ; _ } -> autocomplete in
let rec insert_tree let rec insert_tree
: type a. (ctx, ret) tree -> (a, ctx, ret) params -> (ctx, ret) tree : type a ictx.
= fun t c -> match t, c with (ctx -> ictx) ->
| TEmpty, Stop -> TStop command (ctx, ret) tree -> (a, ictx, ret) params -> (ctx, ret) tree
| TEmpty, Seq (_, _, { autocomplete ; _ }) -> TSeq (command, autocomplete) = fun conv t c ->
| TEmpty, Param (_, _, param, next) -> let insert_tree t c = insert_tree conv t c in
TParam { tree = insert_tree TEmpty next ; stop = None ; autocomplete=access_autocomplete param} match t, c with
| TEmpty, Prefix (n, next) -> | TEmpty, Stop -> TStop command
TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] } | TEmpty, Seq (_, _, { autocomplete ; _ }) -> TSeq (command,
| TStop cmd, Param (_, _, param, next) -> Option.map autocomplete ~f:(fun a c -> a (conv c)))
if not (has_options cmd) | TEmpty, Param (_, _, param, next) ->
then TParam { tree = insert_tree TEmpty next ; let autocomplete = access_autocomplete param in
stop = Some cmd ; let autocomplete = Option.map autocomplete ~f:(fun a c -> a (conv c)) in
autocomplete=access_autocomplete param } TParam { tree = insert_tree TEmpty next ; stop = None ; autocomplete}
else raise (Failure "Command cannot have both prefix and options") | TEmpty, Prefix (n, next) ->
| TStop cmd, Prefix (n, next) -> TPrefix { stop = None ; prefix = [ (n, insert_tree TEmpty next) ] }
TPrefix { stop = Some cmd ; | TStop cmd, Param (_, _, param, next) ->
prefix = [ (n, insert_tree TEmpty next) ] } let autocomplete = access_autocomplete param in
| TParam t, Param (_, _, _, next) -> let autocomplete = Option.map autocomplete ~f:(fun a c -> a (conv c)) in
TParam { t with tree = insert_tree t.tree next } if not (has_options cmd)
| TPrefix ({ prefix ; _ } as l), Prefix (n, next) -> then TParam { tree = insert_tree TEmpty next ;
let rec insert_prefix = function stop = Some cmd ;
| [] -> [ (n, insert_tree TEmpty next) ] autocomplete }
| (n', t) :: rest when n = n' -> (n, insert_tree t next) :: rest else raise (Failure "Command cannot have both prefix and options")
| item :: rest -> item :: insert_prefix rest in | TStop cmd, Prefix (n, next) ->
TPrefix { l with prefix = insert_prefix prefix } TPrefix { stop = Some cmd ;
| TPrefix ({ stop = None ; _ } as l), Stop -> prefix = [ (n, insert_tree TEmpty next) ] }
TPrefix { l with stop = Some command } | TParam t, Param (_, _, _, next) ->
| TParam ({ stop = None ; _ } as l), Stop -> TParam { t with tree = insert_tree t.tree next }
TParam { l with stop = Some command } | TPrefix ({ prefix ; _ } as l), Prefix (n, next) ->
| _, _ -> let rec insert_prefix = function
Pervasives.failwith | [] -> [ (n, insert_tree TEmpty next) ]
"Cli_entries.Command_tree.insert: conflicting commands" in | (n', t) :: rest when n = n' -> (n, insert_tree t next) :: rest
insert_tree root params | 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 = let make_dispatch_tree commands =
List.fold_left insert_in_dispatch_tree TEmpty commands List.fold_left insert_in_dispatch_tree TEmpty commands
@ -1071,8 +1083,8 @@ let complete_tree cctxt tree index args =
end end
| TParam { tree ; _ }, _ :: tl -> | TParam { tree ; _ }, _ :: tl ->
help tree tl (ind - 1) help tree tl (ind - 1)
| TStop Command { options = Argument { spec ; _ } ; _ }, args -> | TStop Command { options = Argument { spec ; _ } ; conv ;_ }, args ->
complete_options (fun _ _ -> return []) args spec ind cctxt complete_options (fun _ _ -> return []) args spec ind (conv cctxt)
| (TParam _ | TPrefix _), [] | (TParam _ | TPrefix _), []
| TEmpty, _ -> return [] | TEmpty, _ -> return []
in help tree args index in help tree args index
@ -1250,3 +1262,6 @@ let () =
Data_encoding.(obj1 (req "arg" string)) Data_encoding.(obj1 (req "arg" string))
(function Unknown_option arg -> Some arg | _ -> None) (function Unknown_option arg -> Some arg | _ -> None)
(fun arg -> Unknown_option arg) (fun arg -> Unknown_option arg)
let map_command f (Command c) =
(Command { c with conv = (fun x -> c.conv (f x)) })

View File

@ -228,3 +228,5 @@ val parse_initial_options :
'ctx -> 'ctx ->
string list -> string list ->
('a * string list) tzresult Lwt.t ('a * string list) tzresult Lwt.t
val map_command: ('a -> 'b) -> ('b, 'c) command -> ('a, 'c) command