(**************************************************************************)
(*  The CDuce compiler                                                    *)
(*  Alain Frisch <Alain.Frisch@inria.fr> and the CDuce team               *)
(*  Copyright CNRS,INRIA, 2003,2004 (see LICENSE for details)             *)
(**************************************************************************)

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.s Imap.s

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

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

let mk_map l =
  let all_ns = ref IntSet.empty in
  let def = ref None in
  List.iter 
    (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;

  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 -> Imap.add x y accu) accu syms
	     | SymbolSet.Cofinite syms ->
		 def := Some y; accu)
        Imap.empty 
        l in
    Imap.prepare !def t
  in

  let t = 
    List.fold_left (fun accu ns -> Imap.add ns (one_ns ns) accu)
      Imap.empty 
      (IntSet.elements !all_ns) in
  let t = Imap.prepare !def t in

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

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

  Format.fprintf Format.std_formatter "table: %a@." 
    (Imap.dump (fun ppf y -> Format.fprintf ppf "[%a]" dump_ns y)) t;
*)

  t





