(******************************************************************************)
(*  SXSI : XPath evaluator                                                    *)
(*  Kim Nguyen (Kim.Nguyen@nicta.com.au)                                      *)
(*  Copyright NICTA 2008                                                      *)
(*  Distributed under the terms of the LGPL (see LICENCE)                     *)
(******************************************************************************)
(*  maybe utf8 string... *)
module T =
struct
  type t = string
      
  (* special tag which denotes attribute nodes, should not be a valid
     xml tag name *)
  let attribute = "<@>"
    (* Likewise for strings *)
  let pcdata = "<$>"
    
  let compare : t -> t -> int = String.compare
    
  let hash (s:t) =
    let rec loop acc = function 
      | -1 -> acc
      |  n -> loop (( acc lsl 6 ) + (acc lsl 16) - acc + (Char.code s.[n])) (n-1)
	   
    in
      loop 0 ((String.length s)-1)
	
  let equal x y = compare x y == 0
end

module HMap = Map.Make (struct type t = int  let compare x y = x - y end)
module HTag =
struct
type t = int
let attribute =  T.hash T.attribute
let pcdata = T.hash  T.pcdata
let pool = ref HMap.empty

let add_pool s =
  let hash = T.hash s in 
    pool := HMap.add hash s !pool
  
let clear_pool () = 
  pool := HMap.empty;
  add_pool "";
  add_pool T.attribute;
  add_pool T.pcdata

  
let _ = clear_pool ()


let tag s = 
  let hash = T.hash s in
    try 
      let s' = HMap.find hash !pool
      in
	if s <> s' then 
	  failwith (Printf.sprintf "hash conflict s1=%s, s2=%s, %i" s s' hash)
	else hash
    with
	Not_found -> 
	  add_pool s;
	  hash

let compare x y = x - y
let equal = (==)
let hash t = T.hash t
let print fmt t = 
  Format.fprintf fmt "%s" (
    try 
      HMap.find t !pool
    with 
	Not_found -> failwith (Printf.sprintf "%i not found!" t))
let to_string x = HMap.find  x !pool

end
module STag =
struct
  type t = string
  let attribute = T.attribute
  let pcdata = T.pcdata
  external tag : string -> t = "%identity"
  external clear_pool : unit -> unit = "%identity"
  let init _ = ()
  let compare = String.compare
  let equal = (=)
  let print fmt s = Format.fprintf fmt "%s" s
  external  to_string : t -> string = "%identity"

end

include STag
let _ = Callback.register "caml_hash_tag" tag