(* Utilities for tags and attributes *)
open Printf
open Protocol
open Tk
open Jtk
open Frx_text
open Fonts
open Jfonts
open Htmlfmt

(* Delayed and shared configuration of tags *)

module TagSet = Set.Make(struct type t = string let compare = compare end)
class tags (thtml) =
  val mutable onhold = []
  val mutable configured = TagSet.empty
  val mutable decorations = []
  val wid = thtml

  (* define a new tag *)
  method define tagname attrs =
    if TagSet.mem tagname configured then ()
    else begin
      onhold <- (tagname,attrs) :: onhold;
      configured <- TagSet.add tagname configured
    end

  method add deco =
    decorations <- deco :: decorations

  (* flush tag definitions *)
  method flush =
    List.iter (fun (t,d) -> 
	try Kanji.text_tag wid t d with TkError _ -> ()) onhold;
    List.iter (fun (t,d,e) -> Text.tag_add wid t d e) decorations;
    onhold <- [];
    decorations <- []
end

(* Conversion of moral attributes to Tk attributes.
 * This virtual class has to be instantiated for each converter.
 * 'a is an logical attribute description (or "delta")
 *)
class virtual 'a nested (tagdef) as self =
  val mutable last_change = 0
  val mutable stack = []
  val tagdef = tagdef

  virtual push_convert : 'a -> string * Jtk.jtkOptions list
  virtual pop_convert : 'a -> unit

  method put current_pos tagname =
   if last_change <> current_pos then begin
     let st = abs_index last_change
     and en = abs_index current_pos in
	tagdef#add (tagname, st, en);
        last_change <- current_pos
   end

  (* Push some new attribute. *)
  method push current_pos desc =
    let tag, attr = self#push_convert desc in
    tagdef#define tag attr;
    begin match stack with
       [] -> 
        (* no current definition, don't issue a put *)
        last_change <- current_pos
     | curtag::l ->
        self#put current_pos curtag
    end;
    stack <- tag :: stack

(* Doesn't check the nature of desc *)
  method pop current_pos (desc : 'a) =
     self#pop_convert desc;
     match stack with
       [] ->
        last_change <- current_pos
     | c::l ->
	stack <- l;
        self#put current_pos c
end

(*
 * Font attributes
 *)

class font (tagdef) =
  inherit (fontInfo list) nested tagdef
  val mutable font_stack = []
  method push_convert fil = 
    let curfd = match font_stack with
      [] -> !Fonts.default
    | x::l -> x in
    let newfd = Fonts.merge curfd fil in
      font_stack <- newfd :: font_stack;
      Jfonts.compute_tag newfd

  method pop_convert _ = 
    match font_stack with
      [] -> ()
    | x::l -> font_stack <- l

end
