Source file utf8.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the               *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public                  *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Handling UTF-8 strings. *)

(** Number of UTF-8 characters in string. *)
let length str =
  Uutf.String.fold_utf_8
    (fun acc _pos -> function
       | `Uchar c -> acc + 1
       | `Malformed str ->
           Log.warn (fun m -> m "Utf8.length: malformed char %S" str);
           acc+1
      )
    0 str

(**/**)
exception Done_chars of Uchar.t list
(**/**)

(** [rev_chars str ~pos ~len] returns the list,
  in reverse order, of characters in [str] from [pos] to [pos+len].
  If [pos] or [len] is invalid, an error message is logged but
  the function returns what it could find.
  Optional argument [acc] can be provided as initial accumulator.
*)
let rev_chars ?(acc=[]) str ~pos ~len =
  try
    let (_,l,acc) = Uutf.String.fold_utf_8
      (fun (nb,l,acc) _pos -> function
         | `Uchar c ->
             if l >= len then
               raise (Done_chars acc)
             else
               if nb < pos then
                 (nb+1,l, acc)
               else
                 (nb+1,l+1,c::acc)
         | `Malformed str ->
             Log.warn (fun m -> m "Utf8.rev_chars: malformed char %S" str);
             (nb+1,l,acc)
      )
        (0,0, acc) str
    in
    if l <> len then
      Log.err
        (fun m -> m "Utf8.rev_chars: invalid argument pos=%d, len=%d but length(s)=%d"
          pos len (length str));
    acc
  with Done_chars l -> l

(**/**)
exception Done of string
(**/**)

(** [sub str ~pos ~len] returns substring of [str] from [pos]
  to [pos+len].
  If [pos] or [len] is invalid, an error message is logged but
 t he function returns what it could find. *)
let sub str ~pos ~len =
  let b = Buffer.create len in
  try
    let (_,l) = Uutf.String.fold_utf_8
      (fun (read,l) _pos -> function
         | `Uchar c ->
             let read = read + 1 in
             if l >= len then
               raise (Done (Buffer.contents b))
             else
               if read <= pos then
                 (read,l)
               else
                 (
                  Uutf.Buffer.add_utf_8 b c;
                  (read,l+1)
                 )
         | `Malformed str ->
             Log.warn (fun m -> m "Utf8.sub: malformed char %S" str);
             (read+1,l)
      )
        (0,0) str
    in
    if l <> len then
      Log.err
        (fun m -> m "Utf8.sub: invalid argument pos=%d, len=%d but length(s)=%d"
          pos len (length str));
    Buffer.contents b
  with Done s -> s

let () = assert (sub "hello" ~pos:4 ~len:1 = "o");;
let () = assert (sub "hello" ~pos:3 ~len:2 = "lo");;
let () = assert (sub "hello" ~pos:5 ~len:0 = "");;

(**/**)
exception Blit_done of int
(**/**)

(** [blit str pos target pos_target len] copies [len] characters from [str]
  beginning at position [pos] to [target] beginning at position [pos_target].
  Returns the number of copied characters. *)
let blit str pos target pos_target len =
  let copied =
    try
      let (_,copied) = Uutf.String.fold_utf_8
        (fun (read,copied) _pos -> function
           | `Uchar c ->
               let read = read + 1 in
               if copied >= len then
                 raise (Blit_done copied)
               else
                 if read <= pos then
                   (read,copied)
                 else
                   (
                    target.(pos_target + copied) <- c;
                    (read,copied+1)
                   )
           | `Malformed str ->
             Log.warn (fun m -> m "Utf8.sub: malformed char %S" str);
               (read+1,copied)
        )
          (0,0) str
      in
      copied
    with Blit_done n -> n
  in
  if copied <> len then
    Log.err
      (fun m -> m "Utf8.sub: invalid argument pos=%d, len=%d but length(s)=%d"
         pos len (length str));
  copied

(** [cut str ~pos ~len] returns three strings, corresponding to
  contents of [str] before pos, contents of [str] between [pos]
  and [pos+len], and contents of [str] after [pos+len].
  Raises [Invalid_argument] if [pos < 0]. *)
let cut str ~pos ~len =
  if pos < 0 then
    invalid_arg (Printf.sprintf "Utf8.cut: invalid pos:%d" pos);
  let b1 = Buffer.create 256 in
  let bremoved = Buffer.create len in
  let b2 = Buffer.create 256 in
  let (_,len_cut) = Uutf.String.fold_utf_8
    (fun (read,len_cut) _pos -> function
       | `Uchar c ->
           let read = read + 1 in
           if read <= pos then
             (
              Uutf.Buffer.add_utf_8 b1 c ;
              (read,len_cut)
             )
           else
             if len_cut >= len then
               (
                Uutf.Buffer.add_utf_8 b2 c;
                (read,len_cut)
               )
             else
               (
                Uutf.Buffer.add_utf_8 bremoved c;
                (read,len_cut+1)
               )
       | `Malformed str ->
           Log.warn (fun m -> m "Utf8.cut: malformed char %S" str);
           (read+1,len_cut)
    )
      (0,0) str
  in
  if len_cut <> len then
    Log.err
      (fun m -> m "Utf8.cut: invalid argument pos=%d, len=%d but len_cut=%d"
         pos len len_cut);
  (Buffer.contents b1,
   Buffer.contents bremoved,
   Buffer.contents b2)

(** [to_chunks max_len str] cuts [str] in chunks of [max_len] characters
  maximum. *)
let to_chunks max_len str =
  let b = Buffer.create max_len in
  let (len,chunks) = Uutf.String.fold_utf_8
    (fun (len,acc) _pos -> function
       | `Uchar c ->
           let (len, acc) =
             if len >= max_len then
               (
                let acc = (len, Buffer.contents b) :: acc in
                Buffer.reset b;
                (0, acc)
               )
             else
               (len, acc)
           in
           Uutf.Buffer.add_utf_8 b c;
           (len+1,acc)
       | `Malformed str ->
           Log.warn (fun m -> m "Utf8.sub: malformed char %S" str);
           Buffer.add_string b str ;
           (len+1,acc)
    )
      (0,[]) str
  in
  let chunks = if len > 0 then (len, Buffer.contents b) :: chunks else chunks in
  List.rev chunks

(** [concat s1 s2] concatenates [s1] and [s2]. *)
let concat s1 s2 = s1 ^ s2

(** [insert str ~pos str2] returns a new string where [str2] was inserted
  in [str] at position [pos]. *)
let insert str ~pos str2 =
  let b = Buffer.create (String.length str * 2) in
  let nb =
    Uutf.String.fold_utf_8
      (fun nb _p -> function
         | `Uchar c ->
             if nb = pos then Buffer.add_string b str2;
             Uutf.Buffer.add_utf_8 b c;
             nb + 1
         | `Malformed str ->
             Log.warn (fun m -> m "Utf8.insert: malformed char %S" str);
             Buffer.add_string b str ;
             nb + 1
      )
      0 str
  in
  if nb - 1 < pos then Buffer.add_string b str2;
  Buffer.contents b

(** [normalize str] performs a [`NFC] normalization to return a new string.
  See {!Uunf_string.normalize_utf_8}.*)
let normalize str = Uunf_string.normalize_utf_8 `NFC str

(** [string_of_uchar c] returns the string corresponding to given Utf68 character [c]. *)
let string_of_uchar c =
  let n_int = Uchar.to_int c in
  let n = Int32.of_int n_int in
  if Int32.compare n (Int32.of_int 128) < 0 then
    String.make 1 (Char.chr n_int)
  else
    let z_mask = Int32.of_int 0b00111111 in
    let z_part = Int32.logand n z_mask in
    let z = Int32.logor (Int32.of_int 0b10000000) z_part in
    if Int32.compare n (Int32.of_int 0x0007FF) <= 0 then
      (
       let y_mask = Int32.of_int 0b0000011111000000 in
       let y_part = Int32.shift_right_logical (Int32.logand n y_mask) 6 in
       let y = Int32.logor (Int32.of_int 0b11000000) y_part in
       let s = Bytes.of_string "12" in
       Bytes.set s 0 (Char.chr (Int32.to_int y)) ;
       Bytes.set s 1 (Char.chr (Int32.to_int z)) ;
       Bytes.to_string s
      )
    else
       let y_mask = Int32.of_int 0b111111000000 in
       let y_part = Int32.shift_right_logical (Int32.logand n y_mask) 6 in
       let y = Int32.logor (Int32.of_int 0b10000000) y_part in
       if Int32.compare n (Int32.of_int 0x00FFFF) <= 0 then
         (
          let x_mask = Int32.of_int (0b1111 lsl 12) in
          let x_part = Int32.shift_right_logical (Int32.logand n x_mask) 12 in
          let x = Int32.logor (Int32.of_int 0b11100000) x_part in
          let s = Bytes.of_string "123" in
          Bytes.set s 0 (Char.chr (Int32.to_int x)) ;
          Bytes.set s 1 (Char.chr (Int32.to_int y)) ;
          Bytes.set s 2 (Char.chr (Int32.to_int z)) ;
          Bytes.to_string s
         )
       else
        if Int32.compare n (Int32.of_int 0x10FFFF) <= 0 then
          (
           let x_mask = Int32.of_int (0b111111 lsl 12) in
           let x_part = Int32.shift_right_logical (Int32.logand n x_mask) 12 in
           let x = Int32.logor (Int32.of_int 0b10000000) x_part in
           let w_mask = Int32.of_int (0b111 lsl 18) in
           let w_part = Int32.shift_right_logical (Int32.logand n w_mask) 18 in
           let w = Int32.logor (Int32.of_int 0b11110000) w_part in
           let s = Bytes.of_string "1234" in
           Bytes.set s 0 (Char.chr (Int32.to_int w)) ;
           Bytes.set s 1 (Char.chr (Int32.to_int x)) ;
           Bytes.set s 2 (Char.chr (Int32.to_int y)) ;
           Bytes.set s 3 (Char.chr (Int32.to_int z)) ;
           Bytes.to_string s
          )
        else
          failwith ("UTF-8 code out of range: "^ (Int32.to_string n))

(** [map f str] returns a new string where each character of [str]
  was mapped by [f]. *)
let map f str =
  let b = Buffer.create (String.length str * 2) in
  Uutf.String.fold_utf_8
    (fun _ _p -> function
       | `Uchar c ->
           Uutf.Buffer.add_utf_8 b (f c)
       | `Malformed str ->
           Log.warn (fun m -> m "Utf8.insert: malformed char %S" str);
           Buffer.add_string b str
    )
    () str;
  Buffer.contents b