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

end
36

37
module SymbolSet = SortedList.FiniteCofinite(Symbol)
38

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

include SortedList.FiniteCofiniteMap(Ns)(SymbolSet)

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

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

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

85
let get_map (ns,x) m =   
86
  Imap.find x (Imap.find ns m)
87

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

let mk_map l =
92
  let all_ns = ref IntSet.empty in
93 94
  let def = ref None in
  List.iter 
95 96 97 98 99
    (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;
100 101 102 103

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

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

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

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

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

  t




140