viewcvs.cgi/types/atoms.ml

open Encodings

module Symbol = Pool.Make(Utf8)

module V = struct

  include Custom.Pair(Ns)(Symbol)

  let atom_table = Hashtbl.create 63

  (* Hash-consing: only to reduce memory usage *)
  (* TODO: also after deserialization ? *)
  let mk ns x =
    let a = (ns, x) in
    try Hashtbl.find atom_table a 
    with Not_found ->
      let b = (ns, Symbol.mk x) in
      Hashtbl.add atom_table a b;
      b

  let of_qname (ns,x) = mk ns x

  let mk_ascii s = mk Ns.empty (Utf8.mk s)
  let get_ascii (_,x) = Utf8.get_str (Symbol.value x)
                     
  let value (ns,x) = (ns, Symbol.value x)
                       
  let print ppf (ns,x) = 
    Format.fprintf ppf "%s" (Ns.InternalPrinter.tag (ns, Symbol.value x))
      
  let print_any_in_ns ppf ns =
    Format.fprintf ppf "%s" (Ns.InternalPrinter.any_ns ns)
      
  let print_quote ppf a = 
    Format.fprintf ppf "`%a" print a

end

module SymbolSet = SortedList.FiniteCofinite(Symbol)

let rec iter_sep sep f = function
  | [] -> ()
  | [ h ] -> f h
  | h :: t -> f h; sep (); iter_sep sep f t
      
let print_symbolset ns ppf = function
  | SymbolSet.Finite l -> 
      iter_sep 
        (fun () -> Format.fprintf ppf " |@ ") 
        (fun x -> V.print_quote ppf (ns,x)) l
  | SymbolSet.Cofinite t ->
      Format.fprintf ppf "@[`%a" V.print_any_in_ns ns;
      List.iter (fun x -> Format.fprintf ppf " \\@ %a" V.print_quote (ns,x)) t;
      Format.fprintf ppf "@]"

include SortedList.FiniteCofiniteMap(Ns)(SymbolSet)

let single s = match get s with
  | `Finite [ns, SymbolSet.Finite [a]] -> (ns,a)
  | `Finite [] -> raise Not_found
  | _ -> raise Exit

let print_tag s = match get s with
  | `Finite [ns, SymbolSet.Finite [a]] -> 
      Some (fun ppf -> V.print ppf (ns,a))
  | `Finite [ns, SymbolSet.Cofinite []] -> 
      Some (fun ppf -> Format.fprintf ppf "%a" V.print_any_in_ns ns)
  | `Cofinite [] ->
      Some (fun ppf -> Format.fprintf ppf "_")
  | _ -> None

let print s = match get s with
  | `Finite l -> 
      List.map (fun (ns,s) ppf -> print_symbolset ns ppf s) l
  | `Cofinite [] ->
      [ fun ppf -> Format.fprintf ppf "Atom" ]
  | `Cofinite l ->
      [ fun ppf ->
          Format.fprintf ppf "Atom";
          List.iter 
            (fun (ns,s) -> 
               Format.fprintf ppf " \\@ (%a)" (print_symbolset ns) s)
            l ]

type 'a map = 'a Imap.t Imap.t

let get_map (ns,x) m =   
  Imap.find_lower (Imap.find_lower m (Upool.int ns)) x

module IntSet = 
  Set.Make(struct type t = int let compare (x:int) y = Pervasives.compare x y end)
module NsSet = Set.Make(Ns)

let create def l = match def with
  | None ->
      (match l with (i,x)::rest -> Imap.create_default x (Array.of_list rest)
         | [] -> assert false)
  | Some d -> Imap.create_default d (Array.of_list l)


let mk_map l =
  let l = List.filter (fun (t,_) -> not (is_empty t)) l in
  if l = [] then Imap.empty
  else
  let all_ns = ref NsSet.empty in
  let def = ref None in
  List.iter 
    (function (s,x) ->
       match get s with
       | `Finite s -> 
           List.iter (fun (ns,_) -> all_ns := NsSet.add ns !all_ns) s
       | `Cofinite _ -> def := Some (Imap.create_default x [||])
    ) l;

  let one_ns ns =
    let def = ref None in
    let t = 
      List.fold_left
        (fun accu (s, y) -> 
           match (symbol_set ns s) with
             | SymbolSet.Finite syms ->
                 List.fold_left (fun accu x -> (x,y)::accu) accu syms
             | SymbolSet.Cofinite syms ->
                 def := Some y; accu)
        [] l in
    create (!def) t
  in

  let t = 
    List.fold_left (fun accu ns -> (Upool.int ns, one_ns ns)::accu) [] 
      (NsSet.elements !all_ns) in
  create (!def) t
1	open Encodings
2
3	module Symbol = Pool.Make(Utf8)
4
5	module V = struct
6
7	include Custom.Pair(Ns)(Symbol)
8
9	let atom_table = Hashtbl.create 63
10
11	(* Hash-consing: only to reduce memory usage *)
12	(* TODO: also after deserialization ? *)
13	let mk ns x =
14	let a = (ns, x) in
15	try Hashtbl.find atom_table a
16	with Not_found ->
17	let b = (ns, Symbol.mk x) in
18	Hashtbl.add atom_table a b;
19	b
20
21	let of_qname (ns,x) = mk ns x
22
23	let mk_ascii s = mk Ns.empty (Utf8.mk s)
24	let get_ascii (_,x) = Utf8.get_str (Symbol.value x)
25
26	let value (ns,x) = (ns, Symbol.value x)
27
28	let print ppf (ns,x) =
29	Format.fprintf ppf "%s" (Ns.InternalPrinter.tag (ns, Symbol.value x))
30
31	let print_any_in_ns ppf ns =
32	Format.fprintf ppf "%s" (Ns.InternalPrinter.any_ns ns)
33
34	let print_quote ppf a =
35	Format.fprintf ppf "`%a" print a
36
37	end
38
39	module SymbolSet = SortedList.FiniteCofinite(Symbol)
40
41	let rec iter_sep sep f = function
42	\| [] -> ()
43	\| [ h ] -> f h
44	\| h :: t -> f h; sep (); iter_sep sep f t
45
46	let print_symbolset ns ppf = function
47	\| SymbolSet.Finite l ->
48	iter_sep
49	(fun () -> Format.fprintf ppf " \|@ ")
50	(fun x -> V.print_quote ppf (ns,x)) l
51	\| SymbolSet.Cofinite t ->
52	Format.fprintf ppf "@[`%a" V.print_any_in_ns ns;
53	List.iter (fun x -> Format.fprintf ppf " \\@ %a" V.print_quote (ns,x)) t;
54	Format.fprintf ppf "@]"
55
56	include SortedList.FiniteCofiniteMap(Ns)(SymbolSet)
57
58	let single s = match get s with
59	\| `Finite [ns, SymbolSet.Finite [a]] -> (ns,a)
60	\| `Finite [] -> raise Not_found
61	\| _ -> raise Exit
62
63	let print_tag s = match get s with
64	\| `Finite [ns, SymbolSet.Finite [a]] ->
65	Some (fun ppf -> V.print ppf (ns,a))
66	\| `Finite [ns, SymbolSet.Cofinite []] ->
67	Some (fun ppf -> Format.fprintf ppf "%a" V.print_any_in_ns ns)
68	\| `Cofinite [] ->
69	Some (fun ppf -> Format.fprintf ppf "_")
70	\| _ -> None
71
72	let print s = match get s with
73	\| `Finite l ->
74	List.map (fun (ns,s) ppf -> print_symbolset ns ppf s) l
75	\| `Cofinite [] ->
76	[ fun ppf -> Format.fprintf ppf "Atom" ]
77	\| `Cofinite l ->
78	[ fun ppf ->
79	Format.fprintf ppf "Atom";
80	List.iter
81	(fun (ns,s) ->
82	Format.fprintf ppf " \\@ (%a)" (print_symbolset ns) s)
83	l ]
84
85	type 'a map = 'a Imap.t Imap.t
86
87	let get_map (ns,x) m =
88	Imap.find_lower (Imap.find_lower m (Upool.int ns)) x
89
90	module IntSet =
91	Set.Make(struct type t = int let compare (x:int) y = Pervasives.compare x y end)
92	module NsSet = Set.Make(Ns)
93
94	let create def l = match def with
95	\| None ->
96	(match l with (i,x)::rest -> Imap.create_default x (Array.of_list rest)
97	\| [] -> assert false)
98	\| Some d -> Imap.create_default d (Array.of_list l)
99
100
101	let mk_map l =
102	let l = List.filter (fun (t,_) -> not (is_empty t)) l in
103	if l = [] then Imap.empty
104	else
105	let all_ns = ref NsSet.empty in
106	let def = ref None in
107	List.iter
108	(function (s,x) ->
109	match get s with
110	\| `Finite s ->
111	List.iter (fun (ns,_) -> all_ns := NsSet.add ns !all_ns) s
112	\| `Cofinite _ -> def := Some (Imap.create_default x [\|\|])
113	) l;
114
115	let one_ns ns =
116	let def = ref None in
117	let t =
118	List.fold_left
119	(fun accu (s, y) ->
120	match (symbol_set ns s) with
121	\| SymbolSet.Finite syms ->
122	List.fold_left (fun accu x -> (x,y)::accu) accu syms
123	\| SymbolSet.Cofinite syms ->
124	def := Some y; accu)
125	[] l in
126	create (!def) t
127	in
128
129	let t =
130	List.fold_left (fun accu ns -> (Upool.int ns, one_ns ns)::accu) []
131	(NsSet.elements !all_ns) in
132	create (!def) t