From 00697c62348a2aabe650ada4605c0589feda5bae Mon Sep 17 00:00:00 2001
From: =?utf8?q?Kim=20Nguy=E1=BB=85n?= <kim.nguyen@lri.fr>
Date: Tue, 18 Apr 2017 14:42:10 +0200
Subject: [PATCH] Add the node summary to the Tree interface.

---
 src/compact_tree.ml | 21 ++++++++++++---------
 src/naive_tree.ml   | 32 ++++++++++++++++++++------------
 src/tree.ml         | 45 +++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 77 insertions(+), 21 deletions(-)

diff --git a/src/compact_tree.ml b/src/compact_tree.ml
index 485f5ff..b716cd7 100644
--- a/src/compact_tree.ml
+++ b/src/compact_tree.ml
@@ -24,7 +24,7 @@ open Bigarray
 type table = int array
 type t = {
   table : table;
-  kind : Bytes.t;
+  summary : Bytes.t;
   tags : QName.t array;
   data : string array;
 }
@@ -56,9 +56,11 @@ let parent t n =
 
 let tag t n =
   Array.unsafe_get t.tags (idx n)
+let summary t n =
+  Obj.magic (String.unsafe_get t.summary (idx n))
 
 let kind t n : Tree.NodeKind.t =
-  Obj.magic (String.unsafe_get t.kind (idx n))
+  Tree.NodeSummary.kind (summary t n)
 
 let preorder t n =
   (idx n) - 2
@@ -129,11 +131,11 @@ 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 =
+let mk_node table_a data_a kind_a tags_a i summary 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);
+    Bytes.unsafe_set kind_a (i+2)  (Char.chr (summary land 0xff));
     let n = (i+2) * 3 in
     let fc = (pre_fc + 2) * 3 in
     let ns = (pre_ns + 2) * 3 in
@@ -150,19 +152,20 @@ let of_naive t =
   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;
+  let summaries = Bytes.make (s+2) '\000' in
+  mk_node table data summaries tags ~-2 Tree.NodeSummary.dummy dummy_tag "" dummy dummy dummy;
+  mk_node table data summaries tags ~-1 Tree.NodeSummary.dummy 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)
+    mk_node table data summaries tags i
+      (Naive_tree.summary 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 }
+  { data; table; tags ; summary = summaries }
 
 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)
diff --git a/src/naive_tree.ml b/src/naive_tree.ml
index 89b9e86..a7194be 100644
--- a/src/naive_tree.ml
+++ b/src/naive_tree.ml
@@ -16,7 +16,7 @@
 type node = {
   tag : QName.t;
   preorder : int;
-  mutable kind : Tree.NodeKind.t;
+  mutable summary : Tree.NodeSummary.t;
   mutable data : string;
   mutable first_child : node;
   mutable next_sibling : node;
@@ -27,7 +27,7 @@ type node = {
 
 let rec nil = {
   tag = QName.nil;
-  kind = Tree.NodeKind.Element;
+  summary = Tree.NodeSummary.dummy;
   preorder = -1;
   data = "";
   first_child = nil;
@@ -38,7 +38,7 @@ let rec nil = {
 let dummy_tag = QName.of_string "#dummy"
 let rec dummy = {
   tag = dummy_tag;
-  kind = Tree.NodeKind.Element;
+  summary = Tree.NodeSummary.dummy;
   preorder = -1;
   data = "";
   first_child = dummy;
@@ -116,7 +116,7 @@ first_child=%a; next_sibling=%a; parent=%a }"
     do_text parser_ ctx;
     let parent = top ctx in
     let n = { tag = QName.of_string tag;
-              kind = Tree.NodeKind.Element;
+              summary = Tree.NodeSummary.make false false false false Tree.NodeKind.Element;
               preorder = next ctx;
               data = "";
               first_child = dummy;
@@ -133,7 +133,7 @@ first_child=%a; next_sibling=%a; parent=%a }"
     start_element_handler parser_ ctx att [];
     let n = top ctx in
     n.data <- value;
-    n.kind <- Tree.NodeKind.Attribute;
+    n.summary <- Tree.NodeSummary.make false false false false Tree.NodeKind.Attribute;
     end_element_handler parser_ ctx att
 
   and consume_closing ctx n =
@@ -156,7 +156,7 @@ first_child=%a; next_sibling=%a; parent=%a }"
       start_element_handler parser_ ctx text_string [];
       let node = top ctx in
       node.data <- s;
-      node.kind <- Tree.NodeKind.Text;
+      node.summary <- Tree.NodeSummary.make false false false false Tree.NodeKind.Text;
       end_element_handler parser_ ctx text_string
 
   and comment_handler parser_ ctx s =
@@ -164,7 +164,7 @@ first_child=%a; next_sibling=%a; parent=%a }"
     start_element_handler parser_ ctx comment_string [];
     let node = top ctx in
     node.data <- s;
-    node.kind <- Tree.NodeKind.Comment;
+    node.summary <- Tree.NodeSummary.make false false false false Tree.NodeKind.Comment;
     end_element_handler parser_ ctx comment_string
 
   and processing_instruction_handler parser_ ctx tag data =
@@ -172,7 +172,7 @@ first_child=%a; next_sibling=%a; parent=%a }"
     start_element_handler parser_ ctx tag [];
     let node = top ctx in
     node.data <- data;
-    node.kind <- Tree.NodeKind.ProcessingInstruction;
+    node.summary <- Tree.NodeSummary.make false false false false Tree.NodeKind.ProcessingInstruction;
     end_element_handler parser_ ctx tag
 
 
@@ -193,7 +193,7 @@ first_child=%a; next_sibling=%a; parent=%a }"
       (processing_instruction_handler psr ctx);
     push { tag = QName.document;
            preorder = next ctx;
-           kind = Tree.NodeKind.Document;
+           summary = Tree.NodeSummary.make false false false false Tree.NodeKind.Document;
            data = "";
            first_child = dummy;
            next_sibling = dummy;
@@ -211,6 +211,13 @@ first_child=%a; next_sibling=%a; parent=%a }"
        let rec loop n =
          if n != nil then
            begin
+             n.summary <-
+               Tree.NodeSummary.make
+                 (n == n.parent.first_child)
+                 (n == n.parent.next_sibling)
+                 (n.first_child != nil)
+                 (n.next_sibling != nil)
+                 (Tree.NodeSummary.kind n.summary);
              a.(n.preorder) <- n;
              loop n.first_child;
              loop n.next_sibling;
@@ -269,9 +276,11 @@ let output_escape_string out s =
     | c -> output_char out c
   done
 
+let kind _ n = Tree.NodeSummary.kind n.summary
+let summary _ n = n.summary
 
 let rec print_attributes ?(sep=true) out tree_ node =
-  if (node.kind == Tree.NodeKind.Attribute) then
+  if (kind tree_ node == Tree.NodeKind.Attribute) then
     let tag = QName.to_string node.tag in
     if sep then output_char out ' ';
     output_string out tag;
@@ -286,7 +295,7 @@ let rec print_xml out tree_ node =
   if node != nil then
   let () =
     let open Tree.NodeKind in
-    match node.kind with
+    match kind tree_ node with
     | Node -> ()
     | Text -> output_escape_string out node.data
     | Element | Document ->
@@ -326,7 +335,6 @@ let next_sibling _ n = n.next_sibling
 let parent _ n = n.parent
 let tag _ n = n.tag
 let data _ n = n.data
-let kind _ n = n.kind
 let preorder _ n = n.preorder
 let by_preorder t i =
  if i >= 0 && i < t.size then Array.unsafe_get t.by_preorder i
diff --git a/src/tree.ml b/src/tree.ml
index 525f8c7..2696707 100644
--- a/src/tree.ml
+++ b/src/tree.ml
@@ -12,6 +12,7 @@
 (*  ../LICENSE.                                                        *)
 (*                                                                     *)
 (***********************************************************************)
+open Misc
 
 (** The different kind of XML nodes and utility functions *)
 
@@ -38,6 +39,45 @@ module NodeKind =
       k1 == Node || k2 == Node || k1 == k2
 end
 
+
+module NodeSummary =
+struct
+  (* Pack into an integer the result of the is_* and has_ predicates
+     for a given node *)
+  type t = int
+  let dummy = -1
+  (*
+    ...44443210
+    ...4444 -> kind
+    3 -> has_right
+    2 -> has_left
+    1 -> is_right
+    0 -> is_left
+  *)
+  let is_left (s : t) : bool =
+    s land 1 != 0
+
+  let is_right (s : t) : bool =
+    s land 0b10 != 0
+
+  let has_left (s : t) : bool =
+    s land 0b100 != 0
+
+  let has_right (s : t) : bool =
+    s land 0b1000 != 0
+
+  let kind (s : t) : NodeKind.t =
+    Obj.magic (s lsr 4)
+
+  let make is_left is_right has_left has_right kind =
+    (int_of_bool is_left) lor
+      ((int_of_bool is_right) lsl 1) lor
+      ((int_of_bool has_left) lsl 2) lor
+      ((int_of_bool has_right) lsl 3) lor
+      ((Obj.magic kind) lsl 4)
+end
+
+
 (** Signatures for trees *)
 
 exception Parse_error of string
@@ -104,6 +144,9 @@ sig
   val kind : t -> node -> NodeKind.t
   (** Returns the kind of the given node *)
 
+  val summary : t -> node -> NodeSummary.t
+  (** Returns the summary of the given node *)
+
   val preorder : t -> node -> int
   (** [preorder t n] returns the pre-order position of [n] in [t].
       [preodrder t (root t) == 0] and [preorder t nil < 0].
@@ -113,4 +156,6 @@ sig
   (** [by_preorder t i] returns the node with preorder [i]
   *)
   val print_node : Format.formatter -> node -> unit
+
+  val dispatch ('a -> 'b -> QName.t -> NodeSummary.t -> node -> node 
 end
-- 
2.17.1