-module Binary =
-struct
-
- type string_content = string
- type descr = Nil | Node of node_content | String of string_content
- and node_content = int*Tag.t * descr * descr * (descr ref)
- type t = descr
-
- let descr t = t
-
- let string = function String s -> s | _ -> failwith "string"
-
-
- external parse_xml_uri : string -> t = "caml_call_shredder_uri"
- external parse_xml_string : string -> t = "caml_call_shredder_string"
-
- let parse_xml_uri s = Node(0,Tag.tag "",parse_xml_uri s,Nil,ref Nil)
- let parse_xml_string s = Node(0,Tag.tag "",parse_xml_string s,Nil,ref Nil)
- let tstring = function Nil -> "Nil"
- | Node (_,_,_,_,_) -> "Node"
- | String _ -> "String"
-
-
-let print_xml fmt t =
- let pp_str = Format.pp_print_string fmt in
- let rec loop = function Nil -> ()
- | String (s) -> pp_str s
- | Node (_,t,l,r,_) when Tag.equal t Tag.pcdata -> loop l;loop r
- | Node (_,t,l,r,_) ->
- pp_str ("<" ^ (Tag.to_string t));
- ( match l with
- Nil -> pp_str "/>"
- | Node(_,t',atts,children,_) when Tag.equal t' Tag.attribute ->
- (loop_attributes atts;
- match children with
- | Nil -> pp_str "/>"
- | _ ->
- pp_str ">";
- loop children;
- pp_str ("</"^ (Tag.to_string t)^">" )
- )
- | _ -> pp_str ">"; loop l;
- pp_str ("</"^ (Tag.to_string t)^">" );
- );loop r
- and loop_attributes = function
- | Node(_,t,Node(_,_,String(s),_,_),r,_) ->
- pp_str (" "^(Tag.to_string t)^"=\""^ s ^"\"") ;
- loop_attributes r
- | _ -> ()
-
- in
- loop t
-
-let print_xml fmt =
- function Node(i,t,l,_,_) -> print_xml fmt (Node(i,t,l,Nil,ref Nil))
- | t -> print_xml fmt t
-
-
-(* a bit ugly but inlining like this makes serialization faster *)
-
-let print_xml_fast outc t =
- let rec loop = function Nil -> ()
- | String (s) -> output_string outc s
- | Node (_,t,l,r,_) when Tag.equal t Tag.pcdata -> loop l;loop r
- | Node (_,t,l,r,_) -> let t = Tag.to_string t in
- output_char outc '<';
- output_string outc t;
- ( match l with
- Nil -> output_string outc "/>"
- | Node(_,t',atts,children,_) when Tag.equal t' Tag.attribute ->
- (loop_attributes atts;
- match children with
- | Nil -> output_string outc "/>"
- | _ ->
- output_char outc '>';
- loop children;
- output_string outc "</";
- output_string outc t;
- output_char outc '>' )
- | _ ->
- output_char outc '>';
- loop l;
- output_string outc "</";
- output_string outc t;
- output_char outc '>'
- );loop r
- and loop_attributes = function
- | Node(_,t,Node(_,_,String(s),_,_),r,_) ->
- output_char outc ' ';
- output_string outc (Tag.to_string t);
- output_string outc "=\"";
- output_string outc s;
- output_char outc '"';
- loop_attributes r
- | _ -> ()
-
- in
- loop t
-
-let print_xml_fast outc =
- function Node(i,t,l,_,_) -> print_xml_fast outc (Node(i,t,l,Nil,ref Nil))
- | t -> print_xml_fast outc t
-
-
-
-let tabs = ref 0
-
-let prtabs fmt =
- for i = 0 to !tabs
- do
- Format.fprintf fmt " "
- done
-
-
-let rec dump fmt t =
- incr tabs;
- let _ = match t with
- | Nil -> prtabs fmt; Format.fprintf fmt "#"
- | String s -> prtabs fmt; Format.fprintf fmt "(String %s)" s
- | Node(id,t,l,r,_) ->
- prtabs fmt;
- Format.fprintf fmt " (tag='";
- Tag.print fmt t;
- Format.fprintf fmt "', id='%i')\n" id;
- prtabs fmt;
- dump fmt l;
- Format.fprintf fmt "\n";
- prtabs fmt;
- dump fmt r;
- Format.fprintf fmt "\n";
- prtabs fmt;prtabs fmt;
- Format.fprintf fmt "(id='%i'end )\n" id
- in decr tabs
-
-
-let dump fmt t =
- tabs:=0;
- dump fmt t;
- tabs:=0
-
-let id = function Node(i,_,_,_,_) -> i
- | _ -> failwith "id"
-
-let tag = function Node(_,t,_,_,_) -> t
- | _ -> failwith "tag"
-
-let left = function Node(_,_,l,_,_) -> l
- | _ -> failwith "left"
-
-let right = function Node(_,_,_,r,_) -> r
- | _ -> failwith "right"
-
-let first_child = left
-let next_sibling = right
-
-let is_root = function Node (_,_,_,_,{contents=Nil}) -> true | _ -> false
-let is_left n = match n with
- | Node (_,_,_,_,{contents=p}) when not(is_root n) && (left p) == n -> true
- | _ -> false
-
-let is_right n = match n with
- | Node (_,_,_,_,{contents=p}) when not(is_root n) && (right p) == n -> true
- | _ -> false
-
-
-let compare t1 t2 = match t1,t2 with
- | Nil,Nil -> 0
- | String s1, String s2 -> String.compare s1 s2
- | Nil, String _ -> -1
- | String _, Nil -> 1
- | Node(i1,_,_,_,_), Node(i2,_,_,_,_) -> i1 - i2
- | _, Node _ -> -1
- | Node _ , _ -> 1
-let equal t1 t2 = (compare t1 t2) == 0
-
-let int_size = Sys.word_size/8
-let ssize s = ((String.length s)/4 +1)*4
-let rec size =
- function Nil -> (int_size,1,0,0)
- | String s -> (int_size + (ssize s),0,1,0)
- | Node(_,_,l,r,_) ->
- let sizel,nl,sl,il = size l
- and sizer,nr,sr,ir = size r
- in
- (sizel+sizer+(7*int_size),nl+nr,sl+sr,il+ir+1)
-let size t =
- let s,n,st,i = size t in
- s/1024,n,st,i
-end
-
-