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