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   summary : Bytes.t;
  28   tags : QName.t array;
  29   data : string array;
  30 }
  31
  32
  33 (* encoding :
  34    i + 0 -> fc
  35    i + 1 -> ns
  36    i + 2 -> p
  37 *)
  38
  39 let next i = i + 3
  40 let idx i = i / 3
  41
  42 let dummy = 0
  43 let nil = next (dummy)
  44 let root _t = next (next dummy)
  45
  46 let size t = (idx (Array.length t.table)) - 2
  47
  48 let first_child t n =
  49   Array.unsafe_get t.table (n + 0)
  50
  51 let next_sibling t n =
  52   Array.unsafe_get t.table (n + 1)
  53
  54 let parent t n =
  55   Array.unsafe_get t.table (n + 2)
  56
  57 let tag t n =
  58   Array.unsafe_get t.tags (idx n)
  59 let summary t n =
  60   Obj.magic (String.unsafe_get t.summary (idx n))
  61
  62 let kind t n : Tree.NodeKind.t =
  63   Tree.NodeSummary.kind (summary t n)
  64
  65 let preorder t n =
  66   (idx n) - 2
  67
  68 let data t n = Array.unsafe_get t.data (idx n)
  69 let by_preorder _ i = (i+2) / 3
  70
  71
  72 let output_escape_string out s =
  73   for i = 0 to String.length s - 1 do
  74     match s.[i] with
  75     | '<' -> output_string out "&lt;"
  76     | '>' -> output_string out "&gt;"
  77     | '&' -> output_string out "&amp;"
  78     | '"' -> output_string out "&quot;"
  79     | '\'' -> output_string out "&apos;"
  80     | c -> output_char out c
  81   done
  82
  83
  84 let rec print_attributes ?(sep=true) stop out tree node =
  85   if (kind tree node == Tree.NodeKind.Attribute) && node != stop then
  86     let tag = QName.to_string (tag tree node) in
  87     if sep then output_char out ' ';
  88     output_string out tag;
  89     output_string out "=\"";
  90     output_escape_string out (data tree node);
  91     output_char out '\"';
  92     print_attributes stop out tree (next_sibling tree node)
  93   else
  94     node
  95
  96 let rec print_xml stop out tree node =
  97   if node != nil  && node != stop then
  98   let () =
  99     let open Tree.NodeKind in
 100     match kind tree node with
 101     | Node -> ()
 102     | Text -> output_escape_string out  (data tree node)
 103     | Element | Document ->
 104         let tag = QName.to_string (tag tree node)in
 105         output_char out '<';
 106         output_string out tag;
 107         let fchild = print_attributes stop out tree (first_child tree node) in
 108         if fchild == nil then output_string out "/>"
 109         else begin
 110           output_char out '>';
 111           print_xml stop out tree fchild;
 112           output_string out "</";
 113           output_string out tag;
 114           output_char out '>'
 115         end
 116     | Attribute -> ignore (print_attributes stop ~sep:false out tree node)
 117     | Comment ->
 118         output_string out "<!--";
 119         output_string out (data tree node);
 120         output_string out "-->"
 121     | ProcessingInstruction ->
 122         output_string out "<?";
 123         output_string out (QName.to_string  (tag tree node));
 124         output_char out ' ';
 125         output_string out (data tree node);
 126         output_string out "?>"
 127   in
 128   print_xml stop out tree (next_sibling tree node)
 129
 130 let print_xml out tree node =
 131   print_xml (next_sibling tree node) out tree node
 132
 133
 134 let mk_node table_a data_a kind_a tags_a i summary tag data pre_fc pre_ns pre_p =
 135   try
 136     data_a.(i+2) <- data;
 137     tags_a.(i+2) <- tag;
 138     Bytes.unsafe_set kind_a (i+2)  (Char.chr (summary land 0xff));
 139     let n = (i+2) * 3 in
 140     let fc = (pre_fc + 2) * 3 in
 141     let ns = (pre_ns + 2) * 3 in
 142     let p = (pre_p + 2) * 3 in
 143     table_a.(n) <- fc;
 144     table_a.(n + 1) <- ns;
 145     table_a.(n + 2) <- p
 146   with _ -> assert false
 147
 148
 149 let of_naive t =
 150   let s = Naive_tree.size t in
 151   let len = (s + 2) * 3 in
 152   let table = Array.make len ~-1 (* int16_unsigned c_layout len *) in
 153   let data = Array.make (s + 2) "" in
 154   let tags = Array.make (s+2) dummy_tag in
 155   let summaries = Bytes.make (s+2) '\000' in
 156   mk_node table data summaries tags ~-2 Tree.NodeSummary.dummy dummy_tag "" dummy dummy dummy;
 157   mk_node table data summaries tags ~-1 Tree.NodeSummary.dummy QName.nil "" nil nil nil;
 158   for i = 0 to s - 1 do
 159     let node = Naive_tree.by_preorder t i in
 160     mk_node table data summaries tags i
 161       (Naive_tree.summary t node)
 162       (Naive_tree.tag t node)
 163       (Naive_tree.data t node)
 164       (Naive_tree.preorder t (Naive_tree.first_child t node))
 165       (Naive_tree.preorder t (Naive_tree.next_sibling t node))
 166       (Naive_tree.preorder t (Naive_tree.parent t node))
 167   done;
 168   { data; table; tags ; summary = summaries }
 169
 170 let load_xml_string s = of_naive (Naive_tree.load_xml_string s)
 171 let load_xml_file f = of_naive (Naive_tree.load_xml_file f)
 172
 173 let print_node fmt n = Format.fprintf fmt "%d" n