Use UTF-8 encoding-safe string truncation in UI

The names of roots can be very long and are truncated in UI in the list of updates. Truncating by number of bytes does not play well with UTF-8 input. This patch makes the truncation safe on UTF-8 encoded strings while keeping the length of truncated strings roughly as before (and the result should also look correct for Western languages, maybe also for other scripts).
oferchen · Sep 18, 2023 · fb3f1cd · fb3f1cd
1 parent 893b380
commit fb3f1cd
Show file tree

Hide file tree

Showing 6 changed files with 53 additions and 12 deletions.
diff --git a/src/.depend b/src/.depend
@@ -1237,11 +1237,13 @@ ubase/umarshal.cmx : \
     ubase/umarshal.cmi
 ubase/umarshal.cmi :
 ubase/util.cmo : \
+    unicode.cmi \
     system.cmi \
     ubase/safelist.cmi \
     ubase/projectInfo.cmo \
     ubase/util.cmi
 ubase/util.cmx : \
+    unicode.cmx \
     system.cmx \
     ubase/safelist.cmx \
     ubase/projectInfo.cmx \

diff --git a/src/ubase/util.ml b/src/ubase/util.ml
@@ -362,11 +362,47 @@ let option2string (prt: 'a -> string) = function
 (*                    String utility functions                               *)
 (*****************************************************************************)
 
-let truncateString string length =
-  let actualLength = String.length string in
-  if actualLength <= length then string^(String.make (length - actualLength) ' ')
-  else if actualLength < 3 then string
-  else (String.sub string 0 (length - 3))^ "..."
+let truncateString s count =
+  (* Truncate a string by counting code points instead of bytes. *)
+  let rec subValidUTF8 ?(extra = 0) s pos len =
+    (* Like [String.sub] but tries to keep the substring a valid UTF-8
+       string (it may not be meaningful in any way but the encoding is not
+       broken). Requires the input string to be valid UTF-8 to work
+       properly.
+       If the initial substring (like a simple [String.sub]) is not valid
+       UTF-8 then it tries to blindly extend (never reduce) the substring
+       until it becomes valid UTF-8. This is a very simple implementation
+       that works without knowing anything about the UTF-8 encoding. *)
+    let totl = String.length s in
+    if pos >= totl then
+      None
+    else if pos + len > totl then
+      Some (String.sub s pos (totl - pos))
+    else
+      let s' = String.sub s pos len in
+      if Unicode.check_utf_8 s' || extra > 5 then
+        Some s'
+      else
+        subValidUTF8 s pos (len + 1) ~extra:(extra + 1)
+  in
+  let rec extractCodepoints pos count s' s =
+    (* Somewhat like [String.sub] but instead of number of bytes, extracts
+       [count] number of code points from the string while [pos] is still
+       counted in bytes. *)
+    match subValidUTF8 s pos 1 with
+    | None -> s'
+    | Some s'' ->
+        if count > 1 then
+          extractCodepoints (pos + String.length s'') (count - 1) (s' ^ s'') s
+        else s' ^ s''
+  in
+  let s = Unicode.compose (Unicode.protect s) in
+  let s' = extractCodepoints 0 (count - 3) "" s in
+  let s'' = extractCodepoints (String.length s') 3 "" s in
+  if String.length s' + String.length s'' < String.length s then
+    s' ^ "..."
+  else
+    s' ^ s''
 
 let findsubstring ?reverse:(rev=false) s1 s2 =
   let l1 = String.length s1 in

diff --git a/src/ubase/util.mli b/src/ubase/util.mli
@@ -52,7 +52,7 @@ module StringMap : Map.S with type key = string
 val stringSetFromList : string list -> StringSet.t
 
 (* String manipulation *)
-val truncateString : string -> int -> string
+val truncateString : string -> int (* number of Unicode code points *) -> string
 val startswith : string -> string -> bool  (* STR,PREFIX *)
 val endswith : string -> string -> bool
 val findsubstring : ?reverse:bool -> string -> string -> int option

diff --git a/src/uicommon.ml b/src/uicommon.ml
@@ -288,7 +288,7 @@ let details2string theRi sep =
   | Different {rc1 = rc1; rc2 = rc2} ->
       let root1str, root2str =
         roots2niceStrings 12 (Globals.roots()) in
-      Printf.sprintf "%s : %s\n%s : %s"
+      Printf.sprintf "%-12s : %s\n%-12s : %s"
         root1str (replicaContent2string rc1 sep)
         root2str (replicaContent2string rc2 sep)
 
@@ -314,7 +314,7 @@ let displayPath previousPath path =
 
 let roots2string () =
   let replica1, replica2 = roots2niceStrings 12 (Globals.roots()) in
-  (Printf.sprintf "%s   %s       " replica1 replica2)
+  (Printf.sprintf "%-12s   %-12s       " replica1 replica2)
 
 type action = AError | ASkip of bool | ALtoR of bool | ARtoL of bool | AMerge
 

diff --git a/src/uicommon.mli b/src/uicommon.mli
@@ -60,6 +60,7 @@ val displayPath : Path.t -> Path.t -> string
 (* Format the names of the roots for display at the head of the
    corresponding columns in the UI *)
 val roots2string : unit -> string
+val roots2niceStrings : int -> Common.root * Common.root -> string * string
 
 (* Format a reconItem (and its status string) for display, eliding
    initial components that are the same as the previous path *)

diff --git a/src/uigtk3.ml b/src/uigtk3.ml
@@ -2935,12 +2935,14 @@ let createToplevelWindow () =
     (GTree.view_column ~title:"  Path  "
        ~renderer:(GTree.cell_renderer_text [], ["text", c_path]) ()));
 
-  let setMainWindowColumnHeaders s =
+  let setMainWindowColumnHeaders roots =
+    let escape s = String.split_on_char '_' s |> String.concat "__" in
+    let (r1, r2) = Uicommon.roots2niceStrings 15 roots in
     Array.iteri
       (fun i data ->
          (mainWindow#get_column i)#set_title data)
-      [| " " ^ Unicode.protect (String.sub s  0 12) ^ " "; "  Action  ";
-         " " ^ Unicode.protect (String.sub s 15 12) ^ " "; "  Status  ";
+      [| " " ^ Unicode.protect (escape r1) ^ " "; "  Action  ";
+         " " ^ Unicode.protect (escape r2) ^ " "; "  Status  ";
          " Path" |];
   in
 
@@ -4399,7 +4401,7 @@ let createToplevelWindow () =
   updateFromProfile :=
     (fun () ->
        displayNewProfileLabel ();
-       setMainWindowColumnHeaders (Uicommon.roots2string ());
+       setMainWindowColumnHeaders (Globals.roots ());
        sizeMainWindow ();
        buildActionMenu false);