Source file uunf.ml

(*---------------------------------------------------------------------------
   Copyright (c) 2012 The uunf programmers. All rights reserved.
   Distributed under the ISC license, see terms at the end of the file.
  ---------------------------------------------------------------------------*)

type ret = [ `Uchar of Uchar.t | `End | `Await ]

let pp_ret ppf v = match (v :> ret) with
| `Uchar u -> Format.fprintf ppf "`Uchar U+%04X" (Uchar.to_int u)
| `End -> Format.fprintf ppf "`End"
| `Await -> Format.fprintf ppf "`Await"

let err_exp_await add =
  invalid_arg (Format.asprintf "can't add %a, expected `Await" pp_ret add)

let err_ended add =
  invalid_arg (Format.asprintf "can't add %a, `End already added" pp_ret add)

(* The normalization process is implemented as described in UAX #15
   section 9.1 for normalizing the concatenation of normalized
   strings.  We detect ranges of characters in the input sequence
   enclosed between two characters for which NFX_quick_check=YES *and*
   ccc = 0 (6.1.0 wrongly claims that quick_check=YES implies ccc = 0,
   we therefore call this property nfx_boundary).  Only these ranges
   (including the left boundary) need to be bufferized to perform the
   normalization process. *)

(* Characters *)

let ux_none = max_int                      (* no char, outside unicode range. *)
let u_dumb =                                     (* placeholder, overwritten. *)
  `Uchar (Uchar.of_int 0x0000)

(* Normalization properties. *)

let unicode_version = "14.0.0"

let nfc_boundary u = Uunf_tmapbool.get Uunf_data.nfc_boundary_map u
let nfd_boundary u = Uunf_tmapbool.get Uunf_data.nfd_boundary_map u
let nfkc_boundary u = Uunf_tmapbool.get Uunf_data.nfkc_boundary_map u
let nfkd_boundary u = Uunf_tmapbool.get Uunf_data.nfkd_boundary_map u
let _ccc u = Uunf_tmapbyte.get Uunf_data.ccc_map u
let ccc u = _ccc (Uchar.to_int u)
let decomp_prop u = Uunf_tmap.get Uunf_data.decomp_map u
let compose_prop u = Uunf_tmap.get Uunf_data.compose_map u

module H = struct                            (* Hangul arithmetic constants. *)
  let sbase = 0xAC00
  let lbase = 0x1100
  let vbase = 0x1161
  let tbase = 0x11A7
  let scount = 11172
  let lcount = 19
  let vcount = 21
  let tcount = 28
  let ncount = 588
  let scount = 11172
end

let decomp u =
  let u = Uchar.to_int u in
  if u < 0xAC00 || 0xD7A3 < u then decomp_prop u else
  begin                                        (* LV or LVT hangul composite *)
    let sindex = u - H.sbase in
    let l = H.lbase + (sindex / H.ncount) in
    let v = H.vbase + (sindex mod H.ncount) / H.tcount in
    let t = H.tbase + (sindex mod H.tcount) in
    if t = H.tbase then [|l; v|] else [|l; v; t|]
  end

(* N.B. to help stream-safe text implementers we *could* use the bits
   25-27 of [(decomp u).(0)] to indicate the number of initial non
   starters in the NFKD decomposition of [u] and bits and 28-30 to
   indicate the non starter count increment. *)

let d_compatibility i = i land (1 lsl 24) > 0
let _d_uchar i = i land 0x1FFFFF
let d_uchar i = Uchar.unsafe_of_int (_d_uchar i)

let _composite u1 u2 =
  if 0x1100 <= u1 && u1 <= 0x1112 then
    begin
      if u2 < 0x1161 || 0x1175 < u2 then ux_none else
      let l = u1 - H.lbase in                         (* LV hangul composite *)
      let v = u2 - H.vbase in
      H.sbase + l * H.ncount + v * H.tcount
    end
  else if 0xAC00 <= u1 && u1 <= 0xD788 && (u1 - 0x0AC00) mod H.tcount = 0 then
    begin
      if u2 < 0x11A8 || u2 > 0x11C3 then ux_none else
      (u1 + u2 - H.tbase)                            (* LVT hangul composite *)
    end
  else match compose_prop u1 with
  | [||] -> ux_none
  | a (* [u2; c; u2'; c'; ...] sorted *) ->
      let len = Array.length a / 2 in
      let i = ref 0 in
      try
        while (!i < len) do
          if a.(!i * 2) = u2 then raise Exit else incr i;
        done;
        ux_none
      with Exit -> (a.(!i * 2 + 1))

let composite u1 u2 =
  let u = _composite (Uchar.to_int u1) (Uchar.to_int u2) in
  if u = ux_none then None else Some (Uchar.unsafe_of_int u)

(* Normalize *)

type form = [ `NFC | `NFD | `NFKC | `NFKD ]
type state =                                            (* normalizer state. *)
| Start                                                   (* no cp seen yet. *)
| Boundary    (* cp with boundary = true found in n.uc, no accumulation yet. *)
| Acc                      (* accumulate until next cp with boundary = true. *)
| Flush          (* next cp with boundary = true found, flush previous data. *)
| End                                      (* end of normalization sequence. *)

type t =
  { form : form;                                      (* normalization form. *)
    compat : bool;            (* true if compatibility decomposition needed. *)
    compose : bool;                           (* true if composition needed. *)
    boundary : int -> bool;                                 (* nfx_boundary. *)
    mutable state : state;                              (* normalizer state. *)
    mutable uc : [`Uchar of Uchar.t];       (* last cp with boundary = true. *)
    mutable acc : int array;                      (* code point accumulator. *)
    mutable first : int;                (* index of first code point in acc. *)
    mutable last : int;                  (* index of last code point in acc. *)
    mutable is_end : bool;}                      (* [true] if `End was seen. *)

let create_acc () = Array.make 35 ux_none
let create form  =
  let boundary, compat, compose = match form with
  | `NFC -> nfc_boundary, false, true
  | `NFD -> nfd_boundary, false, false
  | `NFKC -> nfkc_boundary, true, true
  | `NFKD -> nfkd_boundary, true, false
  in
  { form = (form :> form); compat; compose; boundary; state = Start;
    uc = u_dumb; acc = create_acc (); first = 0; last = -1; is_end = false}

let get_u n = let `Uchar u = n.uc in Uchar.to_int u
let acc_empty n = n.first > n.last
let form n = n.form
let copy n = { n with acc = Array.copy n.acc }
let reset n =
  n.state <- Start; n.uc <- u_dumb; n.acc <- create_acc ();
  n.first <- 0; n.last <- -1; n.is_end <- false

let grow_acc n =
  let len = Array.length n.acc in
  let acc' = Array.make (2 * len) ux_none in
  Array.blit n.acc 0 acc' 0 len; n.acc <- acc'

let ordered_add n u =    (* canonical ordering algorithm via insertion sort. *)
  n.last <- n.last + 1; if n.last = Array.length n.acc then grow_acc n;
  let c = _ccc u in
  if c = 0 then n.acc.(n.last) <- u else
  begin
    let i = ref (n.last - 1) in
    while (!i >= 0 && _ccc (n.acc.(!i)) > c) do
      n.acc.(!i + 1) <- n.acc.(!i); decr i;                  (* shift right. *)
    done;
    n.acc.(!i + 1) <- u
  end

let rec add n u =
  if 0xAC00 <= u && u <= 0xD7A3 then
    begin (* LV or LVT hangul composite, copied from decomp to avoid alloc. *)
      let sindex = u - H.sbase in
      let l = H.lbase + (sindex / H.ncount) in
      let v = H.vbase + (sindex mod H.ncount) / H.tcount in
      let t = H.tbase + (sindex mod H.tcount) in
      if t = H.tbase then (ordered_add n l; ordered_add n v) else
      (ordered_add n l; ordered_add n v; ordered_add n t)
    end
  else
    begin match decomp_prop u with
    | [||] -> ordered_add n u
    | d ->
        if d_compatibility d.(0) && not n.compat then ordered_add n u else
        begin
          add n (_d_uchar d.(0));
          for i = 1 to Array.length d - 1 do add n d.(i) done
        end
    end

let compose n =                         (* canonical composition algorithm. *)
  let rec loop ~last_starter ~prev_ccc i =
    if i > n.last then () else
    let ccc_i = _ccc n.acc.(i) in
    let u_comp = _composite n.acc.(last_starter) n.acc.(i) in
    match (u_comp = ux_none || (ccc_i = 0 && last_starter <> i - 1)) with
    | true ->
        let last_starter = if ccc_i = 0 then i else last_starter in
        loop ~last_starter ~prev_ccc:ccc_i (i + 1)
    | false ->
        match prev_ccc <> 0 && prev_ccc >= ccc_i with
        | true -> loop ~last_starter ~prev_ccc:ccc_i (i + 1)
        | false ->
            n.acc.(last_starter) <- u_comp;
            Array.blit n.acc (i + 1) n.acc i (n.last - i);
            n.last <- n.last - 1;
            let prev_ccc = _ccc n.acc.(last_starter) in
            loop ~last_starter ~prev_ccc (last_starter + 1)
  in
  let last_starter = n.first in
  let prev_ccc = _ccc n.acc.(last_starter) in
  loop ~last_starter ~prev_ccc (last_starter + 1)

let flush_next n =
  let ret = `Uchar (Uchar.unsafe_of_int n.acc.(n.first)) in
  if n.first = n.last then (n.first <- 0; n.last <- -1) else
  (n.first <- n.first + 1);
  ret

let flush_start n = if n.compose then compose n; flush_next n
let add n = function
| `Uchar u as uc ->
    let u = Uchar.to_int u in
    begin match n.state with
    | Boundary ->
        if n.boundary u
        then (let prev = n.uc in n.uc <- uc; (prev :> ret))
        else (n.state <- Acc; add n (get_u n); add n u; `Await)
    | Acc ->
        if n.boundary u
        then (n.state <- Flush; n.uc <- uc; flush_start n)
        else (add n u; `Await)
    | Start ->
        if n.boundary u
        then (n.state <- Boundary; n.uc <- uc; `Await)
        else (n.state <- Acc; add n u; `Await)
    | Flush -> err_exp_await uc
    | End -> err_ended uc
    end
| `Await ->
    begin match n.state with
    | Flush ->
        if not (acc_empty n) then flush_next n else
        if n.is_end then (n.state <- End; `End) else
        (n.state <- Boundary; `Await)
    | Start | Boundary | Acc -> `Await
    | End -> `End
    end
| `End ->
    n.is_end <- true;
    begin match n.state with
    | Boundary -> n.state <- End; (n.uc :> ret)
    | Acc -> n.state <- Flush; flush_start n
    | Start -> n.state <- End; `End
    | Flush -> err_exp_await `End
    | End -> err_ended `End
    end

(*---------------------------------------------------------------------------
   Copyright (c) 2012 The uunf programmers

   Permission to use, copy, modify, and/or distribute this software for any
   purpose with or without fee is hereby granted, provided that the above
   copyright notice and this permission notice appear in all copies.

   THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
   WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
   MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
   ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
   WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
   ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
   OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  ---------------------------------------------------------------------------*)