Nested Commands #24

dune-project

@@ -1,2 +1,4 @@
-(lang dune 1.4)
-(name cmdliner)
+(lang dune 2.7)
+(name cmdliner)
+
+(cram enable)

src/cmdliner.ml

@@ -216,15 +216,15 @@ module Term = struct
       ?err:(err_ppf = Format.err_formatter)
       ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) ((al, f), ti) =
     let term = Cmdliner_info.term_add_args ti al in
-    let ei = Cmdliner_info.eval ~term ~main:term ~choices:[] ~env in
+    let ei = Cmdliner_info.eval ~env (Simple term) in
     let args = remove_exec argv in
     let ei, res = term_eval ~catch ei f args in
     do_result help_ppf err_ppf ei res
 
   let choose_term main choices = function
-  | [] -> Ok (main, [])
+  | [] -> Ok (main, [], [fst main])
   | maybe :: args' as args ->
-      if String.length maybe > 1 && maybe.[0] = '-' then Ok (main, args) else
+      if String.length maybe > 1 && maybe.[0] = '-' then Ok (main, args, [fst main]) else
       let index =
         let add acc (choice, _ as c) =
           let name = Cmdliner_info.term_name choice in
@@ -235,7 +235,7 @@ module Term = struct
         List.fold_left add Cmdliner_trie.empty choices
       in
       match Cmdliner_trie.find index maybe with
-      | `Ok choice -> Ok (choice, args')
+      | `Ok choice -> Ok (choice, args', [fst choice ; fst main])
       | `Not_found ->
           let all = Cmdliner_trie.ambiguities index "" in
           let hints = Cmdliner_suggest.value maybe all in
@@ -245,32 +245,139 @@ module Term = struct
           let ambs = List.sort compare ambs in
           Error (Cmdliner_base.err_ambiguous ~kind:"command" maybe ~ambs)
 
-  let eval_choice
-      ?help:(help_ppf = Format.std_formatter)
-      ?err:(err_ppf = Format.err_formatter)
-      ?(catch = true) ?(env = env_default) ?(argv = Sys.argv)
-      main choices =
+  module Group = struct
+    type 'a node =
+    | Term of 'a Cmdliner_term.t
+    | Group of 'a t list
+
+    and 'a t = 'a node * info
+
+    let term_add_args (al, f) info =
+      Cmdliner_info.term_add_args info al
+
+    let rec add_args (node, info) =
+      match node with
+      | Term (al, f) -> (Term (al, f), term_add_args (al, f) info)
+      | Group subs -> (Group (List.map add_args subs), info)
+
+    let (>>=) res f =
+      match res with
+      | Error e -> Error e
+      | Ok x -> f x
+
+    let parse_arg_cmd = function
+    | [] -> Error `No_args
+    | cmd :: args ->
+        if String.length cmd >= 1 && cmd.[0] = '-' then
+          Error `No_args
+        else
+        Ok (cmd, args)
+
+    let cmd_name (_, info) = Cmdliner_info.term_name info
+
+    let one_of (cmd, (choices : _ t list), path, args) =
+      let index =
+        let add acc c =
+          let name = cmd_name c in
+          match Cmdliner_trie.add acc name c with
+          | `New t -> t
+          | `Replaced (c', _) ->
+              let flip (x, y) = (y, x) in
+              invalid_arg (err_multi_cmd_def name (flip c) (flip c'))
+        in
+        List.fold_left add Cmdliner_trie.empty choices
+      in
+      match Cmdliner_trie.find index cmd with
+      | `Ok (choice, info) -> Ok ((choice, info), choices, info :: path, args)
+      | `Not_found ->
+          let all = Cmdliner_trie.ambiguities index "" in
+          let hints = Cmdliner_suggest.value cmd all in
+          Error (`Invalid_command (cmd, path, choices, hints))
+      | `Ambiguous ->
+          let ambs = Cmdliner_trie.ambiguities index cmd in
+          let ambs = List.sort compare ambs in
+          Error (`Ambiguous (cmd, path, ambs))
+
+    let try_one_of choices path args =
+      match parse_arg_cmd args with
+      | Ok (cmd, args) -> one_of (cmd, choices, path, args)
+      | Error `No_args -> Error (`No_args (path, choices))
+
+    let rec try_choose_term choices path args =
+      try_one_of choices path args >>= choose_term
+
+    and choose_term ((t, info), choices, path, args) =
+      match t with
+      | Term t -> Ok ((t, info), choices, path, args)
+      | Group subs -> try_choose_term subs path args
+
+    let choose_term main choices args =
+      let path = [snd main] in
+      match parse_arg_cmd args with
+      | Error `No_args -> Ok (main, choices, path, args)
+      | Ok (cmd, args) -> one_of (cmd, choices, path, args) >>= choose_term
+
+    let eval
+        ?help:(help_ppf = Format.std_formatter)
+        ?err:(err_ppf = Format.err_formatter)
+        ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) main choices =
+    let choices_f = List.map add_args choices in
     let to_term_f ((al, f), ti) = Cmdliner_info.term_add_args ti al, f in
-    let choices_f = List.rev_map to_term_f choices in
+    let main_args = fst main in
     let main_f = to_term_f main in
-    let choices = List.rev_map fst choices_f in
     let main = fst main_f in
-    match choose_term main_f choices_f (remove_exec argv) with
-    | Error err ->
-        let ei = Cmdliner_info.eval ~term:main ~main ~choices ~env in
+    match choose_term (main_args, (fst main_f)) choices_f (remove_exec argv) with
+    | Error (`No_args (path, choices)) ->
+        let err = Cmdliner_base.err_no_sub_command in
+        let sibling_terms = List.map snd choices in
+        let ei = Cmdliner_info.eval ~env
+            (Sub_command { path ; main ; sibling_terms}) in
+        let help, version, ei = add_stdopts ei in
+        let term_args = Cmdliner_info.(term_args @@ eval_term ei) in
+        let args = remove_exec argv in
+        begin match Cmdliner_cline.create ~peek_opts:true term_args args with
+        | Ok cl
+        | Error (_, cl) ->
+            begin match try_eval_stdopts ~catch:true ei cl help version with
+            | Some e -> do_result help_ppf err_ppf ei e
+            | None ->
+                Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err;
+                `Error `Parse
+            end
+        end
+    | Error (`Invalid_command (maybe, path, choices, hints)) ->
+        let err = Cmdliner_base.err_unknown ~kind:"command" maybe ~hints in
+        let sibling_terms = List.map snd choices in
+        let ei =
+          Cmdliner_info.eval ~env (Sub_command { path ; main ; sibling_terms})
+        in
         Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err;
         `Error `Parse
-    | Ok ((chosen, f), args) ->
-        let ei = Cmdliner_info.eval ~term:chosen ~main ~choices ~env in
+    | Error (`Ambiguous (cmd, path, ambs)) ->
+        let err = Cmdliner_base.err_ambiguous ~kind:"command" cmd ~ambs in
+        let sibling_terms = List.map snd choices in
+        let ei =
+          Cmdliner_info.eval ~env (Sub_command { path ; main ; sibling_terms}) in
+        Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err;
+        `Error `Parse
+    | Ok (((_, f), info), sibling_terms, path, args) ->
+        let sibling_terms = List.map snd sibling_terms in
+        let ei = Cmdliner_info.eval ~env
+            (Sub_command { main ; path ; sibling_terms }) in
         let ei, res = term_eval ~catch ei f args in
         do_result help_ppf err_ppf ei res
+  end
+
+  let eval_choice ?help ?err ?catch ?env ?argv main choices =
+    let choices = List.map (fun (c, nfo) -> Group.Term c, nfo) choices in
+    Group.eval ?help ?err ?catch ?env ?argv main choices
 
   let eval_peek_opts
       ?(version_opt = false) ?(env = env_default) ?(argv = Sys.argv)
       ((args, f) : 'a t) =
     let version = if version_opt then Some "dummy" else None in
     let term = Cmdliner_info.term ~args ?version "dummy" in
-    let ei = Cmdliner_info.eval ~term ~main:term ~choices:[] ~env  in
+    let ei = Cmdliner_info.eval ~env (Simple term) in
     (term_eval_peek_opts ei f (remove_exec argv) :> 'a option * 'a result)
 
   (* Exits *)

src/cmdliner.mli

@@ -382,6 +382,31 @@ module Term : sig
       is unspecified the "main" term [t] is evaluated. [i] defines the
       name and man page of the program. *)
 
+  module Group : sig
+    type 'a term
+
+    type 'a node =
+    | Term of 'a term
+    | Group of 'a t list
+    (** The type for an individual command or a command group.
+        {ul
+        {- [Term], individual command term.}
+        {- [Group], a list of command terms in the same group.}} *)
+
+    and 'a t = 'a node * info
+    (** An individual command or a command group annotated with an [info] *)
+
+    val eval :
+      ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool ->
+      ?env:(string -> string option) -> ?argv:string array ->
+      'a term * info -> 'a t list -> 'a result
+    (** [eval help err catch argv (t, i) choices] is like {!eval_choice}
+        except that it will search for term inside the command group [choices]
+
+        If a command group is selected without a sub command, the program will
+        exit with an error message. *)
+  end with type 'a term := 'a t
+
   val eval_peek_opts :
     ?version_opt:bool -> ?env:(string -> string option) ->
     ?argv:string array -> 'a t -> 'a option * 'a result

src/cmdliner_base.ml

@@ -83,6 +83,9 @@ let err_unknown ?(hints = []) ~kind v =
   let hints = match hints with [] -> "." | hs -> did_you_mean (alts_str hs) in
   strf "unknown %s %s%s" kind (quote v) hints
 
+let err_no_sub_command =
+  "is a command group and requires a command argument."
+
 let err_no kind s = strf "no %s %s" (quote s) kind
 let err_not_dir s = strf "%s is not a directory" (quote s)
 let err_is_dir s = strf "%s is a directory" (quote s)

src/cmdliner_base.mli

@@ -20,6 +20,7 @@ val err_ambiguous : kind:string -> string -> ambs:string list -> string
 val err_unknown : ?hints:string list -> kind:string -> string -> string
 val err_multi_def :
   kind:string -> string -> ('b -> string) -> 'b -> 'b -> string
+ val err_no_sub_command : string
 
 (** {1:conv Textual OCaml value converters} *)
 

src/cmdliner_docgen.ml

@@ -60,10 +60,13 @@ let term_info_subst ei = function
 
 let invocation ?(sep = ' ') ei = match Cmdliner_info.eval_kind ei with
 | `Simple | `Multiple_main -> term_name (Cmdliner_info.eval_main ei)
+| `Multiple_group
 | `Multiple_sub ->
-    strf "%s%c%s"
-      Cmdliner_info.(term_name @@ eval_main ei) sep
-      Cmdliner_info.(term_name @@ eval_term ei)
+    let sep = String.make 1 sep in
+    Cmdliner_info.eval_terms_rev ei
+    |> List.rev_map Cmdliner_info.term_name
+    |> String.concat sep
+    |> strf "%s"
 
 let plain_invocation ei = invocation ei
 let invocation ?sep ei = esc @@ invocation ?sep ei
@@ -81,6 +84,7 @@ let synopsis_pos_arg a =
 
 let synopsis ei = match Cmdliner_info.eval_kind ei with
 | `Multiple_main -> strf "$(b,%s) $(i,COMMAND) ..." @@ invocation ei
+| `Multiple_group
 | `Simple | `Multiple_sub ->
     let rev_cli_order (a0, _) (a1, _) =
       Cmdliner_info.rev_arg_pos_cli_order a0 a1
@@ -97,6 +101,7 @@ let synopsis ei = match Cmdliner_info.eval_kind ei with
 
 let cmd_docs ei = match Cmdliner_info.eval_kind ei with
 | `Simple | `Multiple_sub -> []
+| `Multiple_group
 | `Multiple_main ->
     let add_cmd acc t =
       let cmd = strf "$(b,%s)" @@ term_name t in

src/cmdliner_info.ml

@@ -191,28 +191,56 @@ let term_args t = t.term_args
 let term_add_args t args =
   { t with term_args = Args.union args t.term_args }
 
+type eval_kind =
+| Simple of term
+| Main of { term : term ; choices : term list }
+| Sub_command of { path : term list;
+                   main : term;
+                   sibling_terms : term list }
+
 (* Eval info *)
 
 type eval =                     (* information about the evaluation context. *)
   { term : term;                                    (* term being evaluated. *)
     main : term;                                               (* main term. *)
+    path : term list;
     choices : term list;                                (* all term choices. *)
     env : string -> string option }          (* environment variable lookup. *)
 
-let eval ~term ~main ~choices ~env = { term; main; choices; env }
+let eval ~env kind =
+  let (main, term, path, choices) =
+    match kind with
+    | Simple term -> (term, term, [term], [])
+    | Main { term ; choices } -> (term, term, [term], choices)
+    | Sub_command { main ; path ; sibling_terms } ->
+        let term = List.hd path in
+        (main, term, path, sibling_terms)
+  in
+  { term; main; choices; env; path }
+
 let eval_term e = e.term
 let eval_main e = e.main
+let eval_term_path e = e.path
 let eval_choices e = e.choices
 let eval_env_var e v = e.env v
 
 let eval_kind ei =
+  (* subgroup *)
   if ei.choices = [] then `Simple else
   if (ei.term.term_info.term_name == ei.main.term_info.term_name)
-  then `Multiple_main else `Multiple_sub
+  then
+    match ei.path with
+    | [] -> assert false
+    | [_] -> `Multiple_main
+    | _ :: _ :: _ -> `Multiple_group
+  else `Multiple_sub
+
+let eval_terms_rev ei = ei.path
 
 let eval_with_term ei term = { ei with term }
 
 let eval_has_choice e cmd =
+  (* handle subgroup *)
   let is_cmd t = t.term_info.term_name = cmd in
   List.exists is_cmd e.choices
 

src/cmdliner_info.mli

@@ -111,17 +111,23 @@ val term_add_args : term -> args -> term
 
 type eval
 
-val eval :
-  term:term -> main:term -> choices:term list ->
-  env:(string -> string option) -> eval
+type eval_kind =
+| Simple of term
+| Main of { term : term ; choices : term list }
+| Sub_command of { path : term list;
+                   main : term;
+                   sibling_terms : term list }
+
+val eval : env:(string -> string option) -> eval_kind -> eval
 
 val eval_term : eval -> term
 val eval_main : eval -> term
 val eval_choices : eval -> term list
 val eval_env_var : eval -> string -> string option
-val eval_kind : eval -> [> `Multiple_main | `Multiple_sub | `Simple ]
+val eval_kind : eval -> [> `Multiple_main | `Multiple_group | `Multiple_sub | `Simple ]
 val eval_with_term : eval -> term -> eval
 val eval_has_choice : eval -> string -> bool
+val eval_terms_rev : eval -> term list
 
 (*---------------------------------------------------------------------------
    Copyright (c) 2011 Daniel C. Bünzli

src/cmdliner_manpage.ml

@@ -23,6 +23,7 @@ let s_name = "NAME"
 let s_synopsis = "SYNOPSIS"
 let s_description = "DESCRIPTION"
 let s_commands = "COMMANDS"
+let s_command_aliases = "COMMAND ALIASES"
 let s_arguments = "ARGUMENTS"
 let s_options = "OPTIONS"
 let s_common_options = "COMMON OPTIONS"
@@ -45,7 +46,7 @@ let s_see_also = "SEE ALSO"
 let s_created = ""
 let order =
   [| s_name; s_synopsis; s_description; s_created; s_commands;
-     s_arguments; s_options; s_common_options; s_exit_status;
+     s_command_aliases; s_arguments; s_options; s_common_options; s_exit_status;
      s_environment; s_files; s_examples; s_bugs; s_authors; s_see_also; |]
 
 let order_synopsis = 1