atoms.ml 3.42 KB
Newer Older
1
open Encodings
2

3 4
module Symbol = Pool.Make(Utf8)

5 6
module V = struct

7 8 9 10 11 12 13 14 15 16 17 18 19 20
  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

21 22
  let of_qname (ns,x) = mk ns x

23
  let mk_ascii s = mk Ns.empty (Utf8.mk s)
24
  let get_ascii (_,x) = Utf8.get_str (Symbol.value x)
25 26 27 28 29 30 31 32 33 34 35
		     
  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
36 37

end
38

39
module SymbolSet = SortedList.FiniteCofinite(Symbol)
40

41 42 43 44 45 46 47 48 49 50 51 52
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;
53
      List.iter (fun x -> Format.fprintf ppf " \\@ %a" V.print_quote (ns,x)) t;
54 55 56 57
      Format.fprintf ppf "@]"

include SortedList.FiniteCofiniteMap(Ns)(SymbolSet)

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

63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
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) -> 
82
	       Format.fprintf ppf " \\@ (%a)" (print_symbolset ns) s)
83 84
	    l ]

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 ns) x
89

90 91
module IntSet = 
  Set.Make(struct type t = int let compare (x:int) y = Pervasives.compare x y end)
92

93 94 95 96 97 98 99
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)


100
let mk_map l =
101 102 103
  let l = List.filter (fun (t,_) -> not (is_empty t)) l in
  if l = [] then Imap.empty
  else
104
  let all_ns = ref IntSet.empty in
105
  let def = ref None in
106
  List.iter 
107 108 109 110
    (function (s,x) ->
       match get s with
       | `Finite s -> 
	   List.iter (fun (ns,_) -> all_ns := IntSet.add ns !all_ns) s
111
       | `Cofinite _ -> def := Some (Imap.create_default x [||])
112
    ) l;
113 114

  let one_ns ns =
115
    let def = ref None in
116
    let t = 
117 118 119 120
      List.fold_left
        (fun accu (s, y) -> 
	   match (symbol_set ns s) with
	     | SymbolSet.Finite syms ->
121
		 List.fold_left (fun accu x -> (x,y)::accu) accu syms
122
	     | SymbolSet.Cofinite syms ->
123
		 def := Some y; accu)
124
        [] l in
125
    create (!def) t
126 127 128
  in

  let t = 
129
    List.fold_left (fun accu ns -> (ns, one_ns ns)::accu) [] 
130
      (IntSet.elements !all_ns) in
131
  create (!def) t