X-Git-Url: http://git.nguyen.vg/gitweb/?p=tatoo.git;a=blobdiff_plain;f=src%2Fcompact_tree.ml;fp=src%2Fcompact_tree.ml;h=83294990122d46f9bc6bc24c9726f93e71ba6fa1;hp=0000000000000000000000000000000000000000;hb=f41ff8d936d971eb0712e458826f6555b83746da;hpb=a96c64d15866719b4c8eb6d98ad7f1fc948e7636

diff --git a/src/compact_tree.ml b/src/compact_tree.ml
new file mode 100644
index 0000000..8329499
--- /dev/null
+++ b/src/compact_tree.ml
@@ -0,0 +1,171 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                               TAToo                                 *)
+(*                                                                     *)
+(*                     Kim Nguyen, LRI UMR8623                         *)
+(*                   Université Paris-Sud & CNRS                       *)
+(*                                                                     *)
+(*  Copyright 2010-2016 Université Paris-Sud and Centre National de la *)
+(*  Recherche Scientifique. All rights reserved.  This file is         *)
+(*  distributed under the terms of the GNU Lesser General Public       *)
+(*  License, with the special exception on linking described in file   *)
+(*  ../LICENSE.                                                        *)
+(*                                                                     *)
+(***********************************************************************)
+
+type node = int
+
+let dummy_tag = QName.of_string "#dummy"
+ (*
+open Bigarray
+*)
+
+(* type table = (int, int16_unsigned_elt, c_layout) Array1.t *)
+type table = int array
+type t = {
+  table : table;
+  kind : Bytes.t;
+  tags : QName.t array;
+  data : string array;
+}
+
+
+(* encoding :
+   i -> kind | QNameId lsl 8
+   i + 1 -> fc
+   i + 2 -> ns
+   i + 3 -> p
+*)
+
+let next i = i + 3
+let idx i = i / 3
+
+let dummy = 0
+let nil = next (dummy)
+let root _t = next (next dummy)
+
+let size t = (idx (Array.length t.table)) - 2
+
+let first_child t n =
+  Array.unsafe_get t.table (n + 0)
+
+let next_sibling t n =
+  Array.unsafe_get t.table (n + 1)
+
+let parent t n =
+  Array.unsafe_get t.table (n + 2)
+
+let tag t n =
+  Array.unsafe_get t.tags (idx n)
+
+let kind t n : Tree.NodeKind.t =
+  Obj.magic (String.unsafe_get t.kind (idx n))
+
+let preorder t n =
+  (idx n) - 2
+
+let data t n = Array.unsafe_get t.data (idx n)
+let by_preorder _ i = (i+2) / 3
+
+
+let output_escape_string out s =
+  for i = 0 to String.length s - 1 do
+    match s.[i] with
+    | '<' -> output_string out "&lt;"
+    | '>' -> output_string out "&gt;"
+    | '&' -> output_string out "&amp;"
+    | '"' -> output_string out "&quot;"
+    | '\'' -> output_string out "&apos;"
+    | c -> output_char out c
+  done
+
+
+let rec print_attributes ?(sep=true) stop out tree node =
+  if (kind tree node == Tree.NodeKind.Attribute) && node != stop then
+    let tag = QName.to_string (tag tree node) in
+    if sep then output_char out ' ';
+    output_string out tag;
+    output_string out "=\"";
+    output_escape_string out (data tree node);
+    output_char out '\"';
+    print_attributes stop out tree (next_sibling tree node)
+  else
+    node
+
+let rec print_xml stop out tree node =
+  if node != nil  && node != stop then
+  let () =
+    let open Tree.NodeKind in
+    match kind tree node with
+    | Node -> ()
+    | Text -> output_escape_string out  (data tree node)
+    | Element | Document ->
+        let tag = QName.to_string (tag tree node)in
+        output_char out '<';
+        output_string out tag;
+        let fchild = print_attributes stop out tree (first_child tree node) in
+        if fchild == nil then output_string out "/>"
+        else begin
+          output_char out '>';
+          print_xml stop out tree fchild;
+          output_string out "</";
+          output_string out tag;
+          output_char out '>'
+        end
+    | Attribute -> ignore (print_attributes stop ~sep:false out tree node)
+    | Comment ->
+        output_string out "<!--";
+        output_string out (data tree node);
+        output_string out "-->"
+    | ProcessingInstruction ->
+        output_string out "<?";
+        output_string out (QName.to_string  (tag tree node));
+        output_char out ' ';
+        output_string out (data tree node);
+        output_string out "?>"
+  in
+  print_xml stop out tree (next_sibling tree node)
+
+let print_xml out tree node =
+  print_xml (next_sibling tree node) out tree node
+
+
+let mk_node table_a data_a kind_a tags_a i kind tag data pre_fc pre_ns pre_p =
+  try
+    data_a.(i+2) <- data;
+    tags_a.(i+2) <- tag;
+    Bytes.unsafe_set kind_a (i+2)  (Obj.magic kind);
+    let n = (i+2) * 3 in
+    let fc = (pre_fc + 2) * 3 in
+    let ns = (pre_ns + 2) * 3 in
+    let p = (pre_p + 2) * 3 in
+    table_a.(n) <- fc;
+    table_a.(n + 1) <- ns;
+    table_a.(n + 2) <- p
+  with _ -> assert false
+
+
+let of_naive t =
+  let s = Naive_tree.size t in
+  let len = (s + 2) * 3 in
+  let table = Array.make len ~-1 (* int16_unsigned c_layout len *) in
+  let data = Array.make (s + 2) "" in
+  let tags = Array.make (s+2) dummy_tag in
+  let kind = Bytes.make (s+2) '\000' in
+  mk_node table data kind tags ~-2 Tree.NodeKind.Element dummy_tag "" dummy dummy dummy;
+  mk_node table data kind tags ~-1 Tree.NodeKind.Element QName.nil "" nil nil nil;
+  for i = 0 to s - 1 do
+    let node = Naive_tree.by_preorder t i in
+    mk_node table data kind tags i (Naive_tree.kind t node)
+      (Naive_tree.tag t node)
+      (Naive_tree.data t node)
+      (Naive_tree.preorder t (Naive_tree.first_child t node))
+      (Naive_tree.preorder t (Naive_tree.next_sibling t node))
+      (Naive_tree.preorder t (Naive_tree.parent t node))
+  done;
+  { data; table; tags ; kind }
+
+let load_xml_string s = of_naive (Naive_tree.load_xml_string s)
+let load_xml_file f = of_naive (Naive_tree.load_xml_file f)
+
+let print_node fmt n = Format.fprintf fmt "%d" n