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