Ocaml <-> C++ binding

[tatoo.git] / src / bindings / c++ / tatoo_driver.ml

diff --git a/src/bindings/c++/tatoo_driver.ml b/src/bindings/c++/tatoo_driver.ml
new file mode 100644 (file)
index 0000000..3b4c561
--- /dev/null
+++ b/src/bindings/c++/tatoo_driver.ml
@@ -0,0 +1,163 @@
+type +'a jvm_pointer
+
+external dereference_object : 'a jvm_pointer -> unit = "dereference_object"
+external get_null : unit -> 'a jvm_pointer = "getNull"
+
+let null = get_null ()
+
+module Java_tree : sig
+  include Tree.S
+  val init_document : node -> int -> t
+end =
+  struct
+
+    type node = [`Node] jvm_pointer
+
+
+    external dereference_node : node -> unit = "dereference_object"
+
+    external node_get_preorder : node -> int = "node_getPreorder"
+
+
+    (*external node_set_preorder : node -> int -> unit = "node_setPreorder"*)
+
+
+    type t = {
+      root  : node;
+      size : int;
+      tag_cache : QName.t array
+    }
+
+    let nil = get_null ()
+
+    let dummy = get_null ()
+
+    let size t = t.size
+
+    let load_xml_file _ = assert false
+    let load_xml_string _ = assert false
+    let print_xml _ _ _ = assert false
+    let root t = t.root
+
+
+
+    external node_get_node_type : node -> int = "node_getNodeType"
+
+    let node_kind_of_int i =
+      Tree.NodeKind.(
+        match i with
+        | 1 -> Element
+        | 2 -> Attribute
+        | 3 | 4 -> Text
+        | 7 -> ProcessingInstruction
+        | 8 -> Comment
+        | 9 -> Document
+        | _ -> failwith ("Unimplemented document kind, please report " ^ string_of_int i)
+      )
+
+
+    external node_get_node_name : node -> string = "node_getNodeName"
+
+    let kind _ node =
+      assert (node != null);
+      node_kind_of_int (node_get_node_type node)
+
+    external node_get_first_child : node -> node = "node_getFirstChild"
+
+    let first_child _ node =
+      if node == nil then nil else
+        node_get_first_child node
+
+    external node_get_next_sibling : node -> node = "node_getNextSibling"
+
+
+    let next_sibling tree node =
+
+      if node == nil then nil else
+        node_get_next_sibling node
+
+    let parent _ _ = assert false
+
+    let data _ _  = assert false
+
+    let tag tree node =
+      if node == nil then QName.nil else
+        let pre = node_get_preorder node in
+        let label = tree.tag_cache.(pre) in
+        if label  != QName.nil then label else
+          let label = node_get_node_name node in
+          let rlabel =
+          Tree.NodeKind.(
+            match kind tree node with
+            | Document -> QName.document
+            | Text -> QName.text
+            | Attribute -> QName.attribute (QName.of_string label)
+            | ProcessingInstruction ->
+              QName.processing_instruction  (QName.of_string label)
+            | _ ->  QName.of_string label
+          )
+          in
+          tree.tag_cache.(pre) <- rlabel; rlabel
+
+    let preorder tree node =
+      if node == nil then -1 else
+        node_get_preorder node
+
+    let finalize t =
+      dereference_object (t.root)
+
+    let init_document node i =
+      let s = { size = i;
+                root = node;
+                tag_cache = Array.create i QName.nil
+              }
+      in
+      Gc.finalise (finalize) s;
+      s
+
+
+    let print_node _ _ = assert false
+    let by_preorder _ _ = assert false
+  end
+
+
+module Java_node_list : Node_list.S with type node = Java_tree.node
+  =
+  struct
+    type node = Java_tree.node
+    type node_list = [`NodeList] jvm_pointer
+    type t = node_list
+    external length : node_list -> int = "nodelist_getLength"
+    external create : unit -> node_list = "nodelist_new"
+    external add : node_list -> node -> node_list = "nodelist_add"
+    external item : node_list -> int -> node = "nodelist_item"
+
+    let add n l =
+      add l n
+
+    let iter f l =
+      for i = 0 to length l - 1 do
+        f (item l i)
+      done
+
+  end
+
+module Runtime = Run.Make(Java_tree)(Java_node_list)
+
+let _ = Callback.register "init_document" Java_tree.init_document
+
+let xpath_compile p =
+  let auto =
+     Xpath.Compile.path
+       (Xpath.Parser.parse (Ulexing.from_utf8_string p))
+  in
+  Ata.print Format.err_formatter auto;
+  Format.pp_print_flush Format.err_formatter ();
+  auto
+
+let _ = Callback.register "xpath_compile" xpath_compile
+
+let auto_evaluate  auto tree list =
+  Runtime.eval auto tree list
+
+let _ = Callback.register "auto_evaluate" auto_evaluate