tag.ml

   1 (******************************************************************************)
   2 (*  SXSI : XPath evaluator                                                    *)
   3 (*  Kim Nguyen (Kim.Nguyen@nicta.com.au)                                      *)
   4 (*  Copyright NICTA 2008                                                      *)
   5 (*  Distributed under the terms of the LGPL (see LICENCE)                     *)
   6 (******************************************************************************)
   7 (*  maybe utf8 string... *)
   8 module T =
   9 struct
  10   type t = string
  11
  12   (* special tag which denotes attribute nodes, should not be a valid
  13      xml tag name *)
  14   let attribute = "<@>"
  15     (* Likewise for strings *)
  16   let pcdata = "<$>"
  17
  18   let compare : t -> t -> int = String.compare
  19
  20   let hash (s:t) =
  21     let rec loop acc = function
  22       | -1 -> acc
  23       |  n -> loop (( acc lsl 6 ) + (acc lsl 16) - acc + (Char.code s.[n])) (n-1)
  24
  25     in
  26       loop 0 ((String.length s)-1)
  27
  28   let equal x y = compare x y == 0
  29 end
  30
  31 module HMap = Map.Make (struct type t = int  let compare x y = x - y end)
  32 module HTag =
  33 struct
  34 type t = int
  35 let attribute =  T.hash T.attribute
  36 let pcdata = T.hash  T.pcdata
  37 let pool = ref HMap.empty
  38
  39 let add_pool s =
  40   let hash = T.hash s in
  41     pool := HMap.add hash s !pool
  42
  43 let clear_pool () =
  44   pool := HMap.empty;
  45   add_pool "";
  46   add_pool T.attribute;
  47   add_pool T.pcdata
  48
  49
  50 let _ = clear_pool ()
  51
  52
  53 let tag s =
  54   let hash = T.hash s in
  55     try
  56       let s' = HMap.find hash !pool
  57       in
  58         if s <> s' then
  59           failwith (Printf.sprintf "hash conflict s1=%s, s2=%s, %i" s s' hash)
  60         else hash
  61     with
  62         Not_found ->
  63           add_pool s;
  64           hash
  65
  66 let compare x y = x - y
  67 let equal = (==)
  68 let hash t = T.hash t
  69 let print fmt t =
  70   Format.fprintf fmt "%s" (
  71     try
  72       HMap.find t !pool
  73     with
  74         Not_found -> failwith (Printf.sprintf "%i not found!" t))
  75 let to_string x = HMap.find  x !pool
  76
  77 end
  78 module STag =
  79 struct
  80   type t = string
  81   let attribute = T.attribute
  82   let pcdata = T.pcdata
  83   external tag : string -> t = "%identity"
  84   external clear_pool : unit -> unit = "%identity"
  85   let compare = String.compare
  86   let equal = (=)
  87   let print fmt s = Format.fprintf fmt "%s" s
  88   external  to_string : t -> string = "%identity"
  89
  90 end
  91
  92 include STag
  93 let _ = Callback.register "caml_hash_tag" tag