atoms.ml 3.51 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 85
	    l ]

type 'a map = 'a Imap.s Imap.s
86

87
let get_map (ns,x) m =   
88
  Imap.find x (Imap.find ns m)
89

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

let mk_map l =
94
  let all_ns = ref IntSet.empty in
95 96
  let def = ref None in
  List.iter 
97 98 99 100 101
    (function (s,x) ->
       match get s with
       | `Finite s -> 
	   List.iter (fun (ns,_) -> all_ns := IntSet.add ns !all_ns) s
       | `Cofinite _ -> def := Some (Imap.return x)) l;
102 103 104 105

  let one_ns ns =
    let def = ref None in
    let t = 
106 107 108 109
      List.fold_left
        (fun accu (s, y) -> 
	   match (symbol_set ns s) with
	     | SymbolSet.Finite syms ->
110
		 List.fold_left (fun accu x -> Imap.add x y accu) accu syms
111
	     | SymbolSet.Cofinite syms ->
112
		 def := Some y; accu)
113
        Imap.empty 
114
        l in
115
    Imap.prepare !def t
116 117 118
  in

  let t = 
119 120
    List.fold_left (fun accu ns -> Imap.add ns (one_ns ns) accu)
      Imap.empty 
121
      (IntSet.elements !all_ns) in
122
  let t = Imap.prepare !def t in
123 124 125 126 127 128 129 130

(*
  let rec rank y i = function
    | (_,x)::_ when x == y -> i
    | _::r -> rank y (succ i) r
    | [] -> assert false in

  let dump_ns =
131
    Imap.dump (fun ppf y -> Format.fprintf ppf "[%i]" (rank y 0 l)) in
132 133

  Format.fprintf Format.std_formatter "table: %a@." 
134
    (Imap.dump (fun ppf y -> Format.fprintf ppf "[%a]" dump_ns y)) t;
135 136 137 138 139 140 141
*)

  t




142