Source file unidata.ml

# 1 "Camomile/internal/unidata.ml"
(** Unicode data *)

(* Copyright (C) 2002, 2003, 2011 Yamagata Yoriyuki *)

(* This library is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2 of *)
(* the License, or (at your option) any later version. *)

(* As a special exception to the GNU Library General Public License, you *)
(* may link, statically or dynamically, a "work that uses this library" *)
(* with a publicly distributed version of this library to produce an *)
(* executable file containing portions of this library, and distribute *)
(* that executable file under terms of your choice, without any of the *)
(* additional requirements listed in clause 6 of the GNU Library General *)
(* Public License. By "a publicly distributed version of this library", *)
(* we mean either the unmodified Library as distributed by the authors, *)
(* or a modified version of this library that is distributed under the *)
(* conditions defined in clause 3 of the GNU Library General Public *)
(* License. This exception does not however invalidate any other reasons *)
(* why the executable file might be covered by the GNU Library General *)
(* Public License . *)

(* This library 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 *)
(* Lesser General Public License for more details. *)

(* You should have received a copy of the GNU Lesser General Public *)
(* License along with this library; if not, write to the Free Software *)
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *)
(* USA *)

(* You can contact the authour by sending email to *)
(* yoriyuki.y@gmail.com *)


module type Type = sig
  val read_data : ?datadir:string -> string -> 'a

  type general_category_type =
    [ `Lu		(* Letter, Uppercase *)
    | `Ll		(* Letter, Lowercase *)
    | `Lt		(* Letter, Titlecase *)
    | `Mn		(* Mark, Non-Spacing *)
    | `Mc		(* Mark, Spacing Combining *)
    | `Me		(* Mark, Enclosing *)
    | `Nd		(* Number, Decimal Digit *)
    | `Nl		(* Number, Letter *)
    | `No		(* Number, Other *)
    | `Zs		(* Separator, Space *)
    | `Zl		(* Separator, Line *)
    | `Zp		(* Separator, Paragraph *)
    | `Cc		(* Other, Control *)
    | `Cf		(* Other, Format *)
    | `Cs		(* Other, Surrogate *)
    | `Co		(* Other, Private Use *)
    | `Cn		(* Other, Not Assigned *)
    | `Lm		(* Letter, Modifier *)
    | `Lo		(* Letter, Other *)
    | `Pc		(* Punctuation, Connector *)
    | `Pd		(* Punctuation, Dash *)
    | `Ps		(* Punctuation, Open *)
    | `Pe		(* Punctuation, Close *)
    | `Pi		(* Punctuation, Initial quote  *)
    | `Pf		(* Punctuation, Final quote  *)
    | `Po		(* Punctuation, Other *)
    | `Sm		(* Symbol, Math *)
    | `Sc		(* Symbol, Currency *)
    | `Sk		(* Symbol, Modifier *)
    | `So ]	(* Symbol, Other *)

  val cat_of_name : string -> general_category_type
  val num_of_cat : general_category_type -> int
  val cat_of_num : int -> general_category_type

  type script_type =
    [ `Common
    | `Inherited
    | `Latin
    | `Greek
    | `Cyrillic
    | `Armenian
    | `Hebrew
    | `Arabic
    | `Syriac
    | `Thaana
    | `Devanagari
    | `Bengali
    | `Gurmukhi
    | `Gujarati
    | `Oriya
    | `Tamil
    | `Telugu
    | `Kannada
    | `Malayalam
    | `Sinhala
    | `Thai
    | `Lao
    | `Tibetan
    | `Myanmar
    | `Georgian
    | `Hangul
    | `Ethiopic
    | `Cherokee
    | `Canadian_Aboriginal
    | `Ogham
    | `Runic
    | `Khmer
    | `Mongolian
    | `Hiragana
    | `Katakana
    | `Bopomofo
    | `Han
    | `Yi
    | `Old_Italic
    | `Gothic
    | `Deseret
    | `Tagalog
    | `Hanunoo
    | `Buhid
    | `Tagbanwa ]

  val script_of_name : string -> script_type
  val script_of_num : int -> script_type
  val num_of_script : script_type -> int

  type decomposition_type =
    [ `Canon | `Font | `NoBreak | `Initial | `Medial | `Final |
      `Isolated | `Circle | `Super | `Sub | `Vertical | `Wide | `Narrow |
      `Small | `Square | `Fraction | `Compat ]

  type decomposition_info =
    (* Already in the canonical form *)
    [ `Canonform
    (* `Composite (dtype, text) :
     * means the given character is decomposed into text by dtype
     * decomposition. *)
    | `HangulSyllable
    | `Composite of decomposition_type * UChar.t list ]

  (* Collation *)

  type ce_type = int		(*collation element*)

  val primary : ce_type -> int
  val secondary : ce_type -> int
  val tertiary : ce_type -> int
  val compose_ce : int -> int -> int -> ce_type
  val complete_ignorable : ce_type

  type ce_tbl = (UChar.t list * ce_type list) list UCharTbl.t

  type variable_option =
    [ `Blanked
    | `Non_ignorable
    | `Shifted
    | `Shift_Trimmed ]

  type col_info =
    {variable_top : int;
     variable_option : variable_option;
     french_accent : bool;
     hiraganaQ : bool;
     hiraganaQ_weight : int;
     tbl : ce_tbl}

  val get_col_info : ?locale:string -> unit -> col_info

  (* If the returned list contains ([u1; u2; ... ;un], [ce1; ce2; ... ;cem]),
     for the given character u, the sequence u u1 u2 ... un corresponds
     sequence of collation elements ce1 ce2 ... cem. the list is in
     decreasing order respect to n. *)
  val ce : ce_tbl -> UChar.t -> (UChar.t list * ce_type list) list

  type localedata =
    {col_info : col_info option}
end

module Make (Config : ConfigInt.Type) = struct

  let read_data ?datadir name =
    let datadir =
      match datadir with
        Some d -> d
      | None -> Config.datadir in
    Database.read datadir "mar" input_value name

  type general_category_type =
    [ `Lu		(* Letter, Uppercase *)
    | `Ll		(* Letter, Lowercase *)
    | `Lt		(* Letter, Titlecase *)
    | `Mn		(* Mark, Non-Spacing *)
    | `Mc		(* Mark, Spacing Combining *)
    | `Me		(* Mark, Enclosing *)
    | `Nd		(* Number, Decimal Digit *)
    | `Nl		(* Number, Letter *)
    | `No		(* Number, Other *)
    | `Zs		(* Separator, Space *)
    | `Zl		(* Separator, Line *)
    | `Zp		(* Separator, Paragraph *)
    | `Cc		(* Other, Control *)
    | `Cf		(* Other, Format *)
    | `Cs		(* Other, Surrogate *)
    | `Co		(* Other, Private Use *)
    | `Cn		(* Other, Not Assigned *)
    | `Lm		(* Letter, Modifier *)
    | `Lo		(* Letter, Other *)
    | `Pc		(* Punctuation, Connector *)
    | `Pd		(* Punctuation, Dash *)
    | `Ps		(* Punctuation, Open *)
    | `Pe		(* Punctuation, Close *)
    | `Pi		(* Punctuation, Initial quote  *)
    | `Pf		(* Punctuation, Final quote  *)
    | `Po		(* Punctuation, Other *)
    | `Sm		(* Symbol, Math *)
    | `Sc		(* Symbol, Currency *)
    | `Sk		(* Symbol, Modifier *)
    | `So ]	(* Symbol, Other *)


  let cat_of_name name =
    match name with
      "Lu" -> `Lu | "Ll" -> `Ll | "Lt" -> `Lt
    | "Mn" -> `Mn | "Mc" -> `Mc | "Me" -> `Me
    | "Nd" -> `Nd | "Nl" -> `Nl | "No" -> `No
    | "Zs" -> `Zs | "Zl" -> `Zl | "Zp" -> `Zp
    | "Cc" -> `Cc | "Cf" -> `Cf | "Cs" -> `Cs | "Co" -> `Co | "Cn" -> `Cn
    | "Lm" -> `Lm | "Lo" -> `Lo
    | "Pc" -> `Pc | "Pd" -> `Pd | "Ps" -> `Ps | "Pe" -> `Pe
    | "Pi" -> `Pi | "Pf" -> `Pf | "Po" -> `Po
    | "Sm" -> `Sm | "Sc" -> `Sc | "Sk" -> `Sk | "So"-> `So
    | _ -> raise Not_found

  let num_of_cat ca =
    match ca with
      `Lu -> 1 | `Ll -> 2 | `Lt -> 3
    | `Mn -> 4 | `Mc -> 5 | `Me -> 6
    | `Nd -> 7 | `Nl -> 8 | `No -> 9
    | `Zs -> 10 | `Zl -> 11 | `Zp -> 12
    | `Cc -> 13 | `Cf -> 14 | `Cs -> 15 | `Co -> 16 | `Cn -> 0
    | `Lm -> 17 | `Lo -> 18
    | `Pc -> 19 | `Pd -> 20 | `Ps -> 21 | `Pe -> 22
    | `Pi -> 23 | `Pf -> 24 | `Po -> 25
    | `Sm -> 26 | `Sc -> 27 | `Sk -> 28 | `So -> 29

  let cat_of_num_tbl : general_category_type array =
    [| `Cn ; `Lu ; `Ll ; `Lt ; `Mn ; `Mc ; `Me ; `Nd ; `Nl ; `No
     ; `Zs ; `Zl ; `Zp ; `Cc ; `Cf ; `Cs ; `Co
     ; `Lm ; `Lo ; `Pc ; `Pd ; `Ps ; `Pe ; `Pi ; `Pf ; `Po
     ; `Sm ; `Sc ; `Sk ; `So |]

  let cat_of_num i = cat_of_num_tbl.(i)

  type script_type =
    [ `Common
    | `Inherited
    | `Latin
    | `Greek
    | `Cyrillic
    | `Armenian
    | `Hebrew
    | `Arabic
    | `Syriac
    | `Thaana
    | `Devanagari
    | `Bengali
    | `Gurmukhi
    | `Gujarati
    | `Oriya
    | `Tamil
    | `Telugu
    | `Kannada
    | `Malayalam
    | `Sinhala
    | `Thai
    | `Lao
    | `Tibetan
    | `Myanmar
    | `Georgian
    | `Hangul
    | `Ethiopic
    | `Cherokee
    | `Canadian_Aboriginal
    | `Ogham
    | `Runic
    | `Khmer
    | `Mongolian
    | `Hiragana
    | `Katakana
    | `Bopomofo
    | `Han
    | `Yi
    | `Old_Italic
    | `Gothic
    | `Deseret
    | `Tagalog
    | `Hanunoo
    | `Buhid
    | `Tagbanwa ]

  (* little hack to maintain 4.02.3 compat with warnings *)
  module String = struct
    [@@@ocaml.warning "-3-32"]
    let lowercase_ascii = StringLabels.lowercase
    include String
  end

  let script_of_name name =
    match String.lowercase_ascii name with
    | "common" -> `Common
    | "inherited" -> `Inherited
    | "latin" -> `Latin
    | "greek" -> `Greek
    | "cyrillic" -> `Cyrillic
    | "armenian" -> `Armenian
    | "hebrew" -> `Hebrew
    | "arabic" -> `Arabic
    | "syriac" -> `Syriac
    | "thaana" -> `Thaana
    | "devanagari" -> `Devanagari
    | "bengali" -> `Bengali
    | "gurmukhi" -> `Gurmukhi
    | "gujarati" -> `Gujarati
    | "oriya" -> `Oriya
    | "tamil" -> `Tamil
    | "telugu" -> `Telugu
    | "kannada" -> `Kannada
    | "malayalam" -> `Malayalam
    | "sinhala" -> `Sinhala
    | "thai" -> `Thai
    | "lao" -> `Lao
    | "tibetan" -> `Tibetan
    | "myanmar" -> `Myanmar
    | "georgian" -> `Georgian
    | "hangul" -> `Hangul
    | "ethiopic" -> `Ethiopic
    | "cherokee" -> `Cherokee
    | "canadian_aboriginal" -> `Canadian_Aboriginal
    | "ogham" -> `Ogham
    | "runic" -> `Runic
    | "khmer" -> `Khmer
    | "mongolian" -> `Mongolian
    | "hiragana" -> `Hiragana
    | "katakana" -> `Katakana
    | "bopomofo" -> `Bopomofo
    | "han" -> `Han
    | "yi" -> `Yi
    | "old_italic" -> `Old_Italic
    | "gothic" -> `Gothic
    | "deseret" -> `Deseret
    | "tagalog" -> `Tagalog
    | "hanunoo" -> `Hanunoo
    | "buhid" -> `Buhid
    | "tagbanwa" -> `Tagbanwa
    | _ -> raise Not_found

  let num_of_script = function
      `Common -> 0
    | `Inherited -> 1
    | `Latin -> 2
    | `Greek -> 3
    | `Cyrillic -> 4
    | `Armenian -> 5
    | `Hebrew -> 6
    | `Arabic -> 7
    | `Syriac -> 8
    | `Thaana -> 9
    | `Devanagari -> 10
    | `Bengali -> 11
    | `Gurmukhi -> 12
    | `Gujarati -> 13
    | `Oriya -> 14
    | `Tamil -> 15
    | `Telugu -> 16
    | `Kannada -> 17
    | `Malayalam -> 18
    | `Sinhala -> 19
    | `Thai -> 20
    | `Lao -> 21
    | `Tibetan -> 22
    | `Myanmar -> 23
    | `Georgian -> 24
    | `Hangul -> 25
    | `Ethiopic -> 26
    | `Cherokee -> 27
    | `Canadian_Aboriginal -> 28
    | `Ogham -> 29
    | `Runic -> 30
    | `Khmer -> 31
    | `Mongolian -> 32
    | `Hiragana -> 33
    | `Katakana -> 34
    | `Bopomofo -> 35
    | `Han -> 36
    | `Yi -> 37
    | `Old_Italic -> 38
    | `Gothic -> 39
    | `Deseret -> 40
    | `Tagalog -> 41
    | `Hanunoo -> 42
    | `Buhid -> 43
    | `Tagbanwa -> 44

  let script_tbl =
    [| `Common; `Inherited; `Latin; `Greek; `Cyrillic; `Armenian; `Hebrew;
       `Arabic; `Syriac; `Thaana; `Devanagari; `Bengali; `Gurmukhi; `Gujarati;
       `Oriya; `Tamil; `Telugu; `Kannada; `Malayalam; `Sinhala; `Thai; `Lao;
       `Tibetan; `Myanmar; `Georgian; `Hangul; `Ethiopic; `Cherokee;
       `Canadian_Aboriginal; `Ogham; `Runic; `Khmer; `Mongolian; `Hiragana;
       `Katakana; `Bopomofo; `Han; `Yi; `Old_Italic; `Gothic; `Deseret; `Tagalog;
       `Hanunoo; `Buhid; `Tagbanwa |]

  let script_of_num i = script_tbl.(i)

  type decomposition_type =
    [ `Canon | `Font | `NoBreak | `Initial | `Medial | `Final |
      `Isolated | `Circle | `Super | `Sub | `Vertical | `Wide | `Narrow |
      `Small | `Square | `Fraction | `Compat ]

  type decomposition_info =
    (* Already in the canonical form *)
    [ `Canonform
    (* `Composite (dtype, text) :
     * means the given character is decomposed into text by dtype
     * decomposition. *)
    | `HangulSyllable
    | `Composite of decomposition_type * UChar.t list ]

  type ce_type = int

  let primary_mask = 0xffff lsl 15
  let secondary_mask = 0xff lsl 7
  let tertiary_mask = 0x7f

  let primary ce = (ce land primary_mask) lsr 15
  let secondary ce = (ce land secondary_mask) lsr 7
  let tertiary ce = ce land tertiary_mask
  let compose_ce w1 w2 w3 = (w1 lsl 15) lor (w2 lsl 7) lor w3
  let complete_ignorable = 0

  type ce_tbl = (UChar.t list * ce_type list) list UCharTbl.t

  type variable_option =
    [ `Blanked
    | `Non_ignorable
    | `Shifted
    | `Shift_Trimmed ]

  type col_info =
    {variable_top : int;
     variable_option : variable_option;
     french_accent : bool;
     hiraganaQ : bool;
     hiraganaQ_weight : int;
     tbl : ce_tbl}

  let default_col_data =
    lazy (read_data "allkeys" : col_info)

  type localedata =
    {col_info : col_info option}

  let read_localedata c =
    let data : localedata = input_value c in
    match data.col_info with
      None -> raise Not_found
    | Some x -> x

  let col_tbl = Hashtbl.create 0

  let get_col_info ?locale () =
    match locale with
      None -> Lazy.force default_col_data
    | Some s ->
      try
        let b = Hashtbl.find col_tbl s in
        match Weak.get b 0 with
          None ->
          Hashtbl.remove col_tbl s;
          raise Not_found
        | Some x -> x
      with Not_found ->
      try
        let info = Locale.read Config.localedir "mar" read_localedata s in
        let b = Weak.create 1 in
        Weak.set b 0 (Some info);
        Hashtbl.add col_tbl s b;
        info
      with
        Not_found -> Lazy.force default_col_data

  let ce tbl u = UCharTbl.get tbl u
end