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
  33 module HTag =
  34 struct
  35 type t = int
  36 let attribute =  T.hash T.attribute
  37 let pcdata = T.hash  T.pcdata
  38
  39 let pool = ref HMap.empty
  40
  41
  42 let add_pool s =
  43   let hash = T.hash s in
  44     pool := HMap.add hash s !pool
  45
  46 let clear_pool () =
  47   pool := HMap.empty;
  48   add_pool "";
  49   add_pool T.attribute;
  50   add_pool T.pcdata
  51
  52 let _ = clear_pool ()
  53
  54 let init l =
  55   clear_pool ()
  56
  57 let tag s =
  58   let hash = T.hash s in
  59     try
  60       let s' = HMap.find hash !pool
  61       in
  62         if s <> s' then
  63           failwith (Printf.sprintf "hash conflict s1=%s, s2=%s, %i" s s' hash)
  64         else hash
  65     with
  66         Not_found ->
  67           add_pool s;
  68           hash
  69
  70 let compare x y = x - y
  71 let equal = (==)
  72 let hash t = T.hash t
  73 let print fmt t =
  74   Format.fprintf fmt "%s" (
  75     try
  76       HMap.find t !pool
  77     with
  78         Not_found -> failwith (Printf.sprintf "%i not found!" t))
  79 let to_string x = HMap.find  x !pool
  80
  81 end
  82 module STag =
  83 struct
  84   type t = string
  85   let attribute = T.attribute
  86   let pcdata = T.pcdata
  87   external tag : string -> t = "%identity"
  88   external clear_pool : unit -> unit = "%identity"
  89   let init _ = ()
  90   let compare = String.compare
  91   let equal = (=)
  92   let print fmt s = Format.fprintf fmt "%s" s
  93   external  to_string : t -> string = "%identity"
  94
  95 end
  96
  97 include STag