src/compact_tree.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                               TAToo                                 *)
   4 (*                                                                     *)
   5 (*                     Kim Nguyen, LRI UMR8623                         *)
   6 (*                   Université Paris-Sud & CNRS                       *)
   7 (*                                                                     *)
   8 (*  Copyright 2010-2016 Université Paris-Sud and Centre National de la *)
   9 (*  Recherche Scientifique. All rights reserved.  This file is         *)
  10 (*  distributed under the terms of the GNU Lesser General Public       *)
  11 (*  License, with the special exception on linking described in file   *)
  12 (*  ../LICENSE.                                                        *)
  13 (*                                                                     *)
  14 (***********************************************************************)
  15
  16 type node = int
  17
  18 let dummy_tag = QName.of_string "#dummy"
  19  (*
  20 open Bigarray
  21 *)
  22
  23 (* type table = (int, int16_unsigned_elt, c_layout) Array1.t *)
  24 type table = int array
  25 type t = {
  26   table : table;
  27   kind : Bytes.t;
  28   tags : QName.t array;
  29   data : string array;
  30 }
  31
  32
  33 (* encoding :
  34    i -> kind | QNameId lsl 8
  35    i + 1 -> fc
  36    i + 2 -> ns
  37    i + 3 -> p
  38 *)
  39
  40 let next i = i + 3
  41 let idx i = i / 3
  42
  43 let dummy = 0
  44 let nil = next (dummy)
  45 let root _t = next (next dummy)
  46
  47 let size t = (idx (Array.length t.table)) - 2
  48
  49 let first_child t n =
  50   Array.unsafe_get t.table (n + 0)
  51
  52 let next_sibling t n =
  53   Array.unsafe_get t.table (n + 1)
  54
  55 let parent t n =
  56   Array.unsafe_get t.table (n + 2)
  57
  58 let tag t n =
  59   Array.unsafe_get t.tags (idx n)
  60
  61 let kind t n : Tree.NodeKind.t =
  62   Obj.magic (String.unsafe_get t.kind (idx n))
  63
  64 let preorder t n =
  65   (idx n) - 2
  66
  67 let data t n = Array.unsafe_get t.data (idx n)
  68 let by_preorder _ i = (i+2) / 3
  69
  70
  71 let output_escape_string out s =
  72   for i = 0 to String.length s - 1 do
  73     match s.[i] with
  74     | '<' -> output_string out "&lt;"
  75     | '>' -> output_string out "&gt;"
  76     | '&' -> output_string out "&amp;"
  77     | '"' -> output_string out "&quot;"
  78     | '\'' -> output_string out "&apos;"
  79     | c -> output_char out c
  80   done
  81
  82
  83 let rec print_attributes ?(sep=true) stop out tree node =
  84   if (kind tree node == Tree.NodeKind.Attribute) && node != stop then
  85     let tag = QName.to_string (tag tree node) in
  86     if sep then output_char out ' ';
  87     output_string out tag;
  88     output_string out "=\"";
  89     output_escape_string out (data tree node);
  90     output_char out '\"';
  91     print_attributes stop out tree (next_sibling tree node)
  92   else
  93     node
  94
  95 let rec print_xml stop out tree node =
  96   if node != nil  && node != stop then
  97   let () =
  98     let open Tree.NodeKind in
  99     match kind tree node with
 100     | Node -> ()
 101     | Text -> output_escape_string out  (data tree node)
 102     | Element | Document ->
 103         let tag = QName.to_string (tag tree node)in
 104         output_char out '<';
 105         output_string out tag;
 106         let fchild = print_attributes stop out tree (first_child tree node) in
 107         if fchild == nil then output_string out "/>"
 108         else begin
 109           output_char out '>';
 110           print_xml stop out tree fchild;
 111           output_string out "</";
 112           output_string out tag;
 113           output_char out '>'
 114         end
 115     | Attribute -> ignore (print_attributes stop ~sep:false out tree node)
 116     | Comment ->
 117         output_string out "<!--";
 118         output_string out (data tree node);
 119         output_string out "-->"
 120     | ProcessingInstruction ->
 121         output_string out "<?";
 122         output_string out (QName.to_string  (tag tree node));
 123         output_char out ' ';
 124         output_string out (data tree node);
 125         output_string out "?>"
 126   in
 127   print_xml stop out tree (next_sibling tree node)
 128
 129 let print_xml out tree node =
 130   print_xml (next_sibling tree node) out tree node
 131
 132
 133 let mk_node table_a data_a kind_a tags_a i kind tag data pre_fc pre_ns pre_p =
 134   try
 135     data_a.(i+2) <- data;
 136     tags_a.(i+2) <- tag;
 137     Bytes.unsafe_set kind_a (i+2)  (Obj.magic kind);
 138     let n = (i+2) * 3 in
 139     let fc = (pre_fc + 2) * 3 in
 140     let ns = (pre_ns + 2) * 3 in
 141     let p = (pre_p + 2) * 3 in
 142     table_a.(n) <- fc;
 143     table_a.(n + 1) <- ns;
 144     table_a.(n + 2) <- p
 145   with _ -> assert false
 146
 147
 148 let of_naive t =
 149   let s = Naive_tree.size t in
 150   let len = (s + 2) * 3 in
 151   let table = Array.make len ~-1 (* int16_unsigned c_layout len *) in
 152   let data = Array.make (s + 2) "" in
 153   let tags = Array.make (s+2) dummy_tag in
 154   let kind = Bytes.make (s+2) '\000' in
 155   mk_node table data kind tags ~-2 Tree.NodeKind.Element dummy_tag "" dummy dummy dummy;
 156   mk_node table data kind tags ~-1 Tree.NodeKind.Element QName.nil "" nil nil nil;
 157   for i = 0 to s - 1 do
 158     let node = Naive_tree.by_preorder t i in
 159     mk_node table data kind tags i (Naive_tree.kind t node)
 160       (Naive_tree.tag t node)
 161       (Naive_tree.data t node)
 162       (Naive_tree.preorder t (Naive_tree.first_child t node))
 163       (Naive_tree.preorder t (Naive_tree.next_sibling t node))
 164       (Naive_tree.preorder t (Naive_tree.parent t node))
 165   done;
 166   { data; table; tags ; kind }
 167
 168 let load_xml_string s = of_naive (Naive_tree.load_xml_string s)
 169 let load_xml_file f = of_naive (Naive_tree.load_xml_file f)
 170
 171 let print_node fmt n = Format.fprintf fmt "%d" n