Basic manpage generation

Signed-off-by: Stephen Sherratt <stephen@sherra.tt>

CHANGES.md

@@ -5,6 +5,7 @@
 ### Changed
 
 - Rename `desc` in APIs to `doc` to avoid confusion with the `description` field of manpages. (#12)
+- Basic manpage generation (#13)
 
 ## 0.4.0
 

src/climate/ansi_style.ml

@@ -1,4 +1,4 @@
-open Import
+open! Import
 
 module Color = struct
   type t =

src/climate/ansi_style.mli

@@ -1,3 +1,5 @@
+open! Import
+
 module Color : sig
   type t =
     [ `Black

src/climate/climate.ml

@@ -69,9 +69,13 @@ module Subcommand = struct
   type t =
     { name : Name.t
     ; doc : string option
+    ; arg_spec : Spec.t
     }
 
-  let help_entry { name; doc } : Help.Subcommands.entry = { Help.name; doc }
+  let command_doc_spec { name; doc; arg_spec } =
+    let args = Spec.command_doc_spec arg_spec in
+    { Command_doc_spec.Subcommand.name; doc; args }
+  ;;
 end
 
 module Arg_parser = struct
@@ -641,21 +645,27 @@ module Arg_parser = struct
 
   let validate t = Spec.validate t.arg_spec
 
-  let help arg_spec (command_line : Command_line.Rich.t) ~doc ~child_subcommands =
-    let sections =
-      { Help.Sections.arg_sections = Spec.help_sections arg_spec
-      ; subcommands = List.map child_subcommands ~f:Subcommand.help_entry
-      }
-    in
-    { Help.program_name = command_line.program
+  let command_doc_spec
+    arg_spec
+    (command_line : Command_line.Rich.t)
+    ~doc
+    ~child_subcommands
+    =
+    let args = Spec.command_doc_spec arg_spec in
+    let subcommands = List.map child_subcommands ~f:Subcommand.command_doc_spec in
+    { Command_doc_spec.program_name = command_line.program
     ; subcommand = command_line.subcommand
     ; doc
-    ; sections
+    ; args
+    ; subcommands
     }
   ;;
 
   let pp_help ppf help_style arg_spec command_line ~doc ~child_subcommands =
-    Help.pp help_style ppf (help arg_spec command_line ~doc ~child_subcommands)
+    Help.pp
+      help_style
+      ppf
+      (command_doc_spec arg_spec command_line ~doc ~child_subcommands)
   ;;
 
   let help_spec =
@@ -707,8 +717,10 @@ module Arg_parser = struct
                   > 0
           then (
             let prose = Option.value prose ~default:Manpage.Prose.empty in
-            let help = help arg_spec context.command_line ~doc ~child_subcommands in
-            let manpage = { Manpage.prose; help; version = help_info.version } in
+            let spec =
+              command_doc_spec arg_spec context.command_line ~doc ~child_subcommands
+            in
+            let manpage = { Manpage.prose; spec; version = help_info.version } in
             print_endline (Manpage.to_troff_string manpage);
             raise Manpage)
           else arg_compute context help_info)
@@ -875,6 +887,10 @@ module Command = struct
     | Print_completion_script_bash -> "Print the bash completion script for this program."
   ;;
 
+  let internal_arg_spec = function
+    | Print_completion_script_bash -> Completion_config.arg_parser.arg_spec
+  ;;
+
   module Subcommand_info = struct
     type t =
       { name : Name.t
@@ -904,6 +920,12 @@ module Command = struct
     | Internal internal -> Some (internal_doc internal)
   ;;
 
+  let command_arg_spec = function
+    | Singleton { arg_parser; _ } -> arg_parser.arg_spec
+    | Group { default_arg_parser; _ } -> default_arg_parser.arg_spec
+    | Internal internal -> internal_arg_spec internal
+  ;;
+
   let singleton ?doc ?prose arg_parser =
     let doc = doc in
     Singleton
@@ -921,7 +943,12 @@ module Command = struct
       List.filter_map children ~f:(fun { info; command } ->
         if info.hidden
         then None
-        else Some { Subcommand.name = info.name; doc = command_doc command })
+        else
+          Some
+            { Subcommand.name = info.name
+            ; doc = command_doc command
+            ; arg_spec = command_arg_spec command
+            })
     in
     let default_arg_parser =
       match default_arg_parser with

src/climate/climate.mli

@@ -58,6 +58,7 @@ module Manpage : sig
     -> ?files:markup list
     -> ?examples:markup list
     -> ?authors:markup list
+    -> ?extra:(string * markup list) list
     -> unit
     -> prose
 end

src/climate/command_doc_spec.ml

@@ -0,0 +1,87 @@
+open! Import
+
+module Value = struct
+  type t =
+    { name : string
+        (* The value name to be used in documentation, such as
+           the "MESSAGE" in "--commit MESSAGE" *)
+    ; required : bool
+    }
+
+  let pp ~format_name ppf t =
+    if t.required
+    then Format.fprintf ppf "<%s>" (format_name t.name)
+    else Format.fprintf ppf "[%s]" (format_name t.name)
+  ;;
+end
+
+module Positional_arg = struct
+  type t =
+    { value : Value.t
+    ; doc : string option
+    }
+end
+
+module Positional_args = struct
+  type t =
+    { fixed : Positional_arg.t list
+    ; repeated : Positional_arg.t option
+    }
+
+  let pp_usage_args ~format_name ppf t =
+    List.iter t.fixed ~f:(fun { Positional_arg.value; _ } ->
+      Format.pp_print_string ppf " ";
+      Value.pp ~format_name ppf value);
+    Option.iter t.repeated ~f:(fun { Positional_arg.value; _ } ->
+      Format.pp_print_string ppf " ";
+      Value.pp ~format_name ppf value;
+      Format.pp_print_string ppf "…")
+  ;;
+end
+
+module Named_arg = struct
+  type t =
+    { names : Name.t Nonempty_list.t
+    ; value : Value.t option
+    ; repeated : bool
+    ; default_string : string option
+    ; doc : string option
+    }
+end
+
+module Named_args = struct
+  type t = Named_arg.t list
+end
+
+module Args = struct
+  type t =
+    { named : Named_args.t
+    ; positional : Positional_args.t
+    }
+
+  let pp_usage_args ~format_positional_args ppf t =
+    if not (List.is_empty t.named)
+    then Format.fprintf ppf " [%s]…" (format_positional_args "OPTION");
+    Positional_args.pp_usage_args ~format_name:format_positional_args ppf t.positional
+  ;;
+end
+
+module Subcommand = struct
+  type t =
+    { name : Name.t
+    ; doc : string option
+    ; args : Args.t
+    }
+end
+
+module Subcommands = struct
+  type t = Subcommand.t list
+end
+
+type t =
+  { program_name : string
+  ; subcommand : string list
+  ; doc : string option
+  ; args : Args.t
+  ; subcommands : Subcommands.t
+  }

src/climate/command_doc_spec.mli

@@ -0,0 +1,76 @@
+open! Import
+
+(** Abstract representations of objects for the purpose of generating
+    documentation *)
+
+module Value : sig
+  type t =
+    { name : string
+        (* The value name to be used in documentation, such as
+           the "MESSAGE" in "--commit MESSAGE" *)
+    ; required : bool
+    }
+
+  val pp : format_name:(string -> string) -> Format.formatter -> t -> unit
+end
+
+module Positional_arg : sig
+  type t =
+    { value : Value.t
+    ; doc : string option
+    }
+end
+
+module Positional_args : sig
+  type t =
+    { fixed : Positional_arg.t list
+    ; repeated : Positional_arg.t option
+    }
+end
+
+module Named_arg : sig
+  type t =
+    { names : Name.t Nonempty_list.t
+    ; value : Value.t option
+    ; repeated : bool
+    ; default_string : string option
+    ; doc : string option
+    }
+end
+
+module Named_args : sig
+  type t = Named_arg.t list
+end
+
+module Args : sig
+  type t =
+    { named : Named_args.t
+    ; positional : Positional_args.t
+    }
+
+  val pp_usage_args
+    :  format_positional_args:(string -> string)
+    -> Format.formatter
+    -> t
+    -> unit
+end
+
+module Subcommand : sig
+  type t =
+    { name : Name.t
+    ; doc : string option
+    ; args : Args.t
+    }
+end
+
+module Subcommands : sig
+  type t = Subcommand.t list
+end
+
+type t =
+  { program_name : string
+  ; subcommand : string list
+  ; doc : string option
+  ; args : Args.t
+  ; subcommands : Subcommands.t
+  }