Add colors to error message hints (#11685)

11 files changed, 31 insertions, 26 deletions

diff --git a/Changes b/Changes
index 496772690a..03f535a8ef 100644
--- a/Changes
+++ b/Changes
@@ -145,6 +145,9 @@ Working version
   modules with mismatching -for-pack
   (Pierre Chambart and Vincent Laviron, review by Mark Shinwell)
 
+- #11646: Add colors to error message hints.
+  (Christiana Anthony, review by Florian Angeletti)
+
 - #11653: Add the -no-absname option to ocamlc, ocamlopt and ocamldep.
   (Abiola Abdulsalam, review by Sébastien Hinderer and Florian Angeletti)
 
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index 3ca816800d..7429b603b0 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -303,7 +303,7 @@ let prepare_error loc = function
       let msg = "Illegal empty character literal ''" in
       let sub =
         [Location.msg
-           "Hint: Did you mean ' ' or a type variable 'a?"] in
+           "@{<hint>Hint@}: Did you mean ' ' or a type variable 'a?"] in
       Location.error ~loc ~sub msg
   | Keyword_as_label kwd ->
       Location.errorf ~loc
diff --git a/parsing/parse.ml b/parsing/parse.ml
index fa84872b6f..a8061974f4 100644
--- a/parsing/parse.ml
+++ b/parsing/parse.ml
@@ -144,9 +144,9 @@ let prepare_error err =
       Location.errorf ~loc
         "Syntax error: strings are immutable, there is no assignment \
          syntax for them.\n\
-         Hint: Mutable sequences of bytes are available in the Bytes module.\n\
-         Hint: Did you mean to use 'Bytes.set'?"
-
+         @{<hint>Hint@}: Mutable sequences of bytes are available in \
+         the Bytes module.\n\
+         @{<hint>Hint@}: Did you mean to use 'Bytes.set'?"
 let () =
   Location.register_error_of_exn
     (function
diff --git a/tools/ocamltex.ml b/tools/ocamltex.ml
index 43e5c03a4c..e6b2c8cd0d 100644
--- a/tools/ocamltex.ml
+++ b/tools/ocamltex.ml
@@ -756,7 +756,7 @@ let process_file file =
           "when parsing a caml_example environment in@ \
            %s, line %d:@,\
            the signature mode is only compatible with \"caml_example*\"@ \
-           Hint: did you forget to add \"*\"?"
+           @{<hint>Hint@}: did you forget to add \"*\"?"
           file (line_number-2);
   | Text_transform.Intersection {line;file;left;right} ->
       fatal
@@ -765,7 +765,8 @@ let process_file file =
          spanned the interval %d-%d,@ \
          intersecting with another \"%a\" transform @ \
          on the %d-%d interval.@ \
-         Hind: did you try to elide a code fragment which raised a warning?"
+         @{<hint>Hint@}: did you try to elide a code fragment \
+         which raised a warning?"
         file (line-2)
         Text_transform.pp left.kind left.start left.stop
         Text_transform.pp right.kind right.start right.stop
diff --git a/typing/env.ml b/typing/env.ml
index fd2353eed2..aeacd42954 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -3540,8 +3540,7 @@ let report_lookup_error _loc env ppf = function
             Location.get_pos_info def_loc.Location.loc_start
           in
           fprintf ppf
-            "@.@[%s@ %s %i@]"
-            "Hint: If this is a recursive definition,"
+            "@.@[@{<hint>Hint@}: If this is a recursive definition,@ %s %i@]"
             "you should add the 'rec' keyword on line"
             line
     end
@@ -3554,8 +3553,7 @@ let report_lookup_error _loc env ppf = function
       | exception Not_found -> spellcheck ppf extract_modules env lid;
       | _ ->
          fprintf ppf
-           "@.@[%s %a, %s@]"
-           "Hint: There is a module type named"
+           "@.@[@{<hint>Hint@}: There is a module type named %a, %s@]"
            !print_longident lid
            "but module types are not modules"
     end
@@ -3571,8 +3569,7 @@ let report_lookup_error _loc env ppf = function
       | exception Not_found -> spellcheck ppf extract_classes env lid;
       | _ ->
          fprintf ppf
-           "@.@[%s %a, %s@]"
-           "Hint: There is a class type named"
+           "@.@[@{<hint>Hint@}: There is a class type named %a, %s@]"
            !print_longident lid
            "but classes are not class types"
     end
@@ -3582,8 +3579,7 @@ let report_lookup_error _loc env ppf = function
       | exception Not_found -> spellcheck ppf extract_modtypes env lid;
       | _ ->
          fprintf ppf
-           "@.@[%s %a, %s@]"
-           "Hint: There is a module named"
+           "@.@[@{<hint>Hint@}: There is a module named %a, %s@]"
            !print_longident lid
            "but modules are not module types"
     end
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 88d67013c5..cbe7f35c15 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -172,7 +172,7 @@ module Conflicts = struct
       | [namespace, a] ->
           Format.fprintf ppf
         "@ \
-         @[<2>Hint: The %a %s has been defined multiple times@ \
+         @[<2>@{<hint>Hint@}: The %a %s has been defined multiple times@ \
          in@ this@ toplevel@ session.@ \
          Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\
          @ Did you try to redefine them?@]"
@@ -180,7 +180,7 @@ module Conflicts = struct
       | (namespace, _) :: _ :: _ ->
       Format.fprintf ppf
         "@ \
-         @[<2>Hint: The %a %a have been defined multiple times@ \
+         @[<2>@{<hint>Hint@}: The %a %a have been defined multiple times@ \
          in@ this@ toplevel@ session.@ \
          Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\
          @ Did you try to redefine them?@]"
@@ -2169,12 +2169,12 @@ let explanation_diff env t3 t4 : (Format.formatter -> unit) option =
     when is_unit env ty1 && unifiable env ty2 t4 ->
       Some (fun ppf ->
         fprintf ppf
-          "@,@[Hint: Did you forget to provide `()' as argument?@]")
+          "@,@[@{<hint>Hint@}: Did you forget to provide `()' as argument?@]")
   | _, Tarrow (_, ty1, ty2, _)
     when is_unit env ty1 && unifiable env t3 ty2 ->
       Some (fun ppf ->
         fprintf ppf
-          "@,@[Hint: Did you forget to wrap the expression using \
+          "@,@[@{<hint>Hint@}: Did you forget to wrap the expression using \
            `fun () ->'?@]")
   | _ ->
       None
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 240b565e84..d87f7be8b0 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -5491,7 +5491,8 @@ let report_literal_type_constraint expected_type const =
     else None
   in
   match const_str, suffix with
-  | Some c, Some s -> [ Location.msg "@[Hint: Did you mean `%s%c'?@]" c s ]
+  | Some c, Some s -> [ Location.msg "@[@{<hint>Hint@}: Did you \
+                                      mean `%s%c'?@]" c s ]
   | _, _ -> []
 
 let report_literal_type_constraint const = function
@@ -5508,7 +5509,7 @@ let report_partial_application = function
       match get_desc tr.Errortrace.got.Errortrace.expanded with
       | Tarrow _ ->
           [ Location.msg
-              "@[Hint: This function application is partial,@ \
+              "@[@{<hint>Hint@}: This function application is partial,@ \
                maybe some arguments are missing.@]" ]
       | _ -> []
     end
@@ -5743,9 +5744,9 @@ let report_error ~loc env = function
           (function ppf ->
              fprintf ppf "but is here used with type");
         if b then
-          fprintf ppf ".@.@[<hov>%s@ %s@ %s@]"
+          fprintf ppf ".@.@[<hov>%s@ @{<hint>Hint@}: Consider using a fully \
+                      explicit coercion@ %s@]"
             "This simple coercion was not fully general."
-            "Hint: Consider using a fully explicit coercion"
             "of the form: `(foo : ty1 :> ty2)'."
       ) ()
   | Not_a_function (ty, explanation) ->
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 3515a36a3f..3c7fae6b88 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -1903,7 +1903,8 @@ let report_error ppf = function
         "@[<hv>This private row type declaration is invalid.@ \
          The type expression on the right-hand side reduces to@;<1 2>%a@ \
          which does not have a free row type variable.@]@,\
-         @[<hv>@[Hint: If you intended to define a private type abbreviation,@ \
+         @[<hv>@[@{<hint>Hint@}: If you intended to define a private \
+         type abbreviation,@ \
          write explicitly@]@;<1 2>private %a@]"
         Printtyp.type_expr ty Printtyp.type_expr ty
 
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 8db5ad0e18..86cc757e01 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -720,7 +720,7 @@ let report_error env ppf = function
         "@[<v>@[The constructor %s is missing from the upper bound@ \
          (between '<'@ and '>')@ of this polymorphic variant@ \
          but is present in@ its lower bound (after '>').@]@,\
-         @[Hint: Either add `%s in the upper bound,@ \
+         @[@{<hint>Hint@}: Either add `%s in the upper bound,@ \
          or remove it@ from the lower bound.@]@]"
          l l
   | Constructor_mismatch (ty, ty') ->
diff --git a/utils/misc.ml b/utils/misc.ml
index eb973a68cc..54796af226 100644
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -588,7 +588,7 @@ let did_you_mean ppf get_choices =
   | [] -> ()
   | choices ->
      let rest, last = split_last choices in
-     Format.fprintf ppf "@\nHint: Did you mean %s%s%s?@?"
+     Format.fprintf ppf "@\n@{<hint>Hint@}: Did you mean %s%s%s?@?"
        (String.concat ", " rest)
        (if rest = [] then "" else " or ")
        last
@@ -654,12 +654,14 @@ module Color = struct
     error: style list;
     warning: style list;
     loc: style list;
+    hint:style list;
   }
 
   let default_styles = {
     warning = [Bold; FG Magenta];
     error = [Bold; FG Red];
     loc = [Bold];
+    hint = [Bold; FG Blue];
   }
 
   let cur_styles = ref default_styles
@@ -672,6 +674,7 @@ module Color = struct
     | Format.String_tag "error" -> (!cur_styles).error
     | Format.String_tag "warning" -> (!cur_styles).warning
     | Format.String_tag "loc" -> (!cur_styles).loc
+    | Format.String_tag "hint" -> (!cur_styles).hint
     | Style s -> s
     | _ -> raise Not_found
 
diff --git a/utils/misc.mli b/utils/misc.mli
index 2e12b24c80..f9c5c97759 100644
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -374,7 +374,6 @@ module Color : sig
     | BG of color (* background *)
     | Bold
     | Reset
-
   type Format.stag += Style of style list
 
   val ansi_of_style_l : style list -> string
@@ -384,6 +383,7 @@ module Color : sig
     error: style list;
     warning: style list;
     loc: style list;
+    hint: style list;
   }
 
   val default_styles: styles