From d8f177696aa665ca3b30ad1d591ae0ce135a7bef Mon Sep 17 00:00:00 2001
From: Jules Aguillon <jules@j3s.fr>
Date: Tue, 12 Nov 2024 11:45:57 +0100
Subject: [PATCH] box_debug: Highlight whitespaces

This avoids whitespaces from being removed by the HTML parser and
highlights strings that contain whitespaces to make them easy to see.
---
 lib/Fmt.ml       |  2 +-
 lib/box_debug.ml | 15 ++++++++++++++-
 2 files changed, 15 insertions(+), 2 deletions(-)

diff --git a/lib/Fmt.ml b/lib/Fmt.ml
index 2fb707203b..157f989f26 100644
--- a/lib/Fmt.ml
+++ b/lib/Fmt.ml
@@ -143,7 +143,7 @@ let utf8_length s =
 let str_as n s =
   let stack = Box_debug.get_stack () in
   with_pp (fun fs ->
-      Box_debug.start_str fs ;
+      Box_debug.start_str fs s ;
       Format_.pp_print_as fs n s ;
       Box_debug.end_str ~stack fs )
 
diff --git a/lib/box_debug.ml b/lib/box_debug.ml
index a2af7e73ab..6637be2bec 100644
--- a/lib/box_debug.ml
+++ b/lib/box_debug.ml
@@ -42,6 +42,11 @@ let css =
   .fits_or_breaks {
     background-color: red;
   }
+  .string_with_whitespaces {
+    background-color: yellow;
+    white-space: pre;
+  }
+
   .tooltiptext {
     visibility: hidden;
     width: min-content;
@@ -132,7 +137,15 @@ let force_newline ?stack fs =
   debugf fs "<div class=\"break force_newline\">force_newline%a</div>"
     stack_tooltip stack
 
-let start_str fs = debugf fs "<span class='string'>"
+let start_str fs s =
+  let extra_class =
+    match String.lfindi s ~f:(fun _ c -> Char.is_whitespace c) with
+    | Some _ ->
+        (* String contains whitespaces, color it *)
+        " string_with_whitespaces"
+    | None -> ""
+  in
+  debugf fs "<span class='string%s'>" extra_class
 
 let end_str ?stack fs = debugf fs "%a</span>" stack_tooltip stack