Allow color in help messages

For now all help messages will use the default color scheme copied from
gleam. In a future change it will become possible to configure the
colours.

Signed-off-by: Stephen Sherratt <[email protected]>

examples/fake_git.ml

@@ -30,7 +30,13 @@ let commit =
   let+ _amend = flag [ "amend" ] ~desc:"Amend a commit"
   and+ _all = flag [ "a" ] ~desc:"Commit all changes"
   and+ _branch = named_opt [ "b"; "branch" ] branch_conv
-  and+ _message = named_opt [ "m"; "message" ] string ~desc:"The commit message"
+  and+ _message =
+    named_opt
+      [ "m"; "message" ]
+      string
+      ~desc:
+        "The commit message. This description is extra long to exercise text wrapping in \
+         help messages."
   and+ _files = pos_all file ~desc:"The files to commit" in
   ()
 ;;

src/climate/ansi_style.ml

@@ -0,0 +1,44 @@
+open Import
+
+module Color = struct
+  type t =
+    [ `Red
+    | `Green
+    | `Yellow
+    | `Blue
+    | `Magenta
+    | `Cyan
+    ]
+end
+
+type t =
+  { bold : bool
+  ; underline : bool
+  ; color : Color.t option
+  }
+
+let default = { bold = false; underline = false; color = None }
+let reset = "\x1b[0m"
+
+let escape { bold; underline; color } =
+  let effects =
+    List.append (if bold then [ ";1" ] else []) (if underline then [ ";4" ] else [])
+  in
+  let color_code =
+    match (color : Color.t option) with
+    | None -> 0
+    | Some `Red -> 31
+    | Some `Green -> 32
+    | Some `Yellow -> 33
+    | Some `Blue -> 34
+    | Some `Magenta -> 35
+    | Some `Cyan -> 36
+  in
+  Printf.sprintf "\x1b[%d%sm" color_code (String.concat ~sep:"" effects)
+;;
+
+let pp_with_style t ppf ~f =
+  Format.pp_print_string ppf (escape t);
+  f ppf;
+  Format.pp_print_string ppf reset
+;;

src/climate/ansi_style.mli

@@ -0,0 +1,19 @@
+module Color : sig
+  type t =
+    [ `Red
+    | `Green
+    | `Yellow
+    | `Blue
+    | `Magenta
+    | `Cyan
+    ]
+end
+
+type t =
+  { bold : bool
+  ; underline : bool
+  ; color : Color.t option
+  }
+
+val default : t
+val pp_with_style : t -> Format.formatter -> f:(Format.formatter -> unit) -> unit

src/climate/climate.ml

@@ -588,7 +588,7 @@ module Arg_parser = struct
   ;;
 
   let pp_help ppf arg_spec command_line ~desc ~child_subcommands =
-    Help.pp ppf (help arg_spec command_line ~desc ~child_subcommands)
+    Help.pp Help.Style.default ppf (help arg_spec command_line ~desc ~child_subcommands)
   ;;
 
   let help_spec =

src/climate/help.ml

@@ -1,5 +1,18 @@
 open Import
 
+module Style = struct
+  type t =
+    { name : Ansi_style.t
+    ; heading : Ansi_style.t
+    }
+
+  let default =
+    { name = { Ansi_style.default with color = Some `Green; bold = true }
+    ; heading = { Ansi_style.default with color = Some `Yellow; bold = true }
+    }
+  ;;
+end
+
 type 'name entry =
   { name : 'name
   ; desc : string option
@@ -111,6 +124,7 @@ module Print = struct
     ;;
 
     let pp_padded
+      (style : Style.t)
       ppf
       ~at_least_one_left_name
       ~right_names_left_padding
@@ -121,7 +135,8 @@ module Print = struct
       let names_value_string =
         names_value_padded_to_string ~at_least_one_left_name ~right_names_left_padding t
       in
-      Format.pp_print_string ppf names_value_string;
+      Ansi_style.pp_with_style style.name ppf ~f:(fun ppf ->
+        Format.pp_print_string ppf names_value_string);
       pp_print_spaces ppf 1;
       Option.iter t.desc ~f:(fun desc ->
         let padding = desc_left_padding - String.length names_value_string in
@@ -155,23 +170,25 @@ module Print = struct
       |> Option.value ~default:0
     ;;
 
-    let pp ppf t =
+    let pp (style : Style.t) ppf t =
       if List.is_empty t.entries
       then ()
       else (
         let at_least_one_left_name =
           List.exists t.entries ~f:(fun { Entry.names; _ } ->
             not (List.is_empty names.left))
         in
-        pp_print_newlines ppf 2;
-        Format.pp_print_string ppf t.heading;
+        pp_print_newlines ppf 1;
+        Ansi_style.pp_with_style style.heading ppf ~f:(fun ppf ->
+          Format.pp_print_string ppf t.heading);
         pp_print_newlines ppf 1;
         let right_names_left_padding = max_left_length t in
         let desc_left_padding =
           max_name_length ~at_least_one_left_name ~right_names_left_padding t
         in
         List.iter t.entries ~f:(fun entry ->
           Entry.pp_padded
+            style
             ppf
             ~at_least_one_left_name
             ~right_names_left_padding
@@ -220,7 +237,7 @@ module Positional_args = struct
       pp_print_elipsis ppf ())
   ;;
 
-  let pp ppf t = Print.Section.pp ppf (to_print_section t)
+  let pp style ppf t = Print.Section.pp style ppf (to_print_section t)
 end
 
 module Named_args = struct
@@ -249,7 +266,7 @@ module Named_args = struct
     }
   ;;
 
-  let pp ppf t = Print.Section.pp ppf (to_print_section t)
+  let pp style ppf t = Print.Section.pp style ppf (to_print_section t)
 end
 
 module Subcommands = struct
@@ -269,7 +286,7 @@ module Subcommands = struct
     }
   ;;
 
-  let pp ppf t = Print.Section.pp ppf (to_print_section t)
+  let pp style ppf t = Print.Section.pp style ppf (to_print_section t)
 end
 
 module Arg_sections = struct
@@ -290,10 +307,10 @@ module Sections = struct
     ; subcommands : Subcommands.t
     }
 
-  let pp ppf t =
-    Positional_args.pp ppf t.arg_sections.positional_args;
-    Named_args.pp ppf t.arg_sections.named_args;
-    Subcommands.pp ppf t.subcommands
+  let pp style ppf t =
+    Positional_args.pp style ppf t.arg_sections.positional_args;
+    Named_args.pp style ppf t.arg_sections.named_args;
+    Subcommands.pp style ppf t.subcommands
   ;;
 end
 
@@ -309,23 +326,25 @@ let pp_command_base ppf t =
   List.iter t.subcommand ~f:(Format.fprintf ppf " %s")
 ;;
 
-let pp_usage ppf t =
-  Format.pp_print_string ppf "Usage: ";
-  if not (List.is_empty t.sections.subcommands)
-  then (
+let pp_usage (style : Style.t) ppf t =
+  Ansi_style.pp_with_style style.heading ppf ~f:(fun ppf ->
+    Format.pp_print_string ppf "Usage: ");
+  Ansi_style.pp_with_style style.name ppf ~f:(fun ppf ->
+    if not (List.is_empty t.sections.subcommands)
+    then (
+      pp_command_base ppf t;
+      Format.pp_print_string ppf " [COMMAND]";
+      Format.pp_print_newline ppf ();
+      Format.pp_print_string ppf "       ");
     pp_command_base ppf t;
-    Format.pp_print_string ppf " [COMMAND]";
-    Format.pp_print_newline ppf ();
-    Format.pp_print_string ppf "       ");
-  pp_command_base ppf t;
-  Arg_sections.pp_usage_args ppf t.sections.arg_sections
+    Arg_sections.pp_usage_args ppf t.sections.arg_sections)
 ;;
 
-let pp ppf t =
+let pp style ppf t =
   Option.iter t.desc ~f:(fun desc ->
     Format.pp_print_string ppf desc;
     pp_print_newlines ppf 2);
-  pp_usage ppf t;
-  Sections.pp ppf t.sections;
-  pp_print_newlines ppf 1
+  pp_usage style ppf t;
+  pp_print_newlines ppf 1;
+  Sections.pp style ppf t.sections
 ;;

src/climate/help.mli

@@ -1,5 +1,14 @@
 open Import
 
+module Style : sig
+  type t =
+    { name : Ansi_style.t
+    ; heading : Ansi_style.t
+    }
+
+  val default : t
+end
+
 type 'name entry =
   { name : 'name
   ; desc : string option
@@ -60,4 +69,4 @@ type t =
   ; sections : Sections.t
   }
 
-val pp : Format.formatter -> t -> unit
+val pp : Style.t -> Format.formatter -> t -> unit