(* HTML Display Machine *)
open Printf
open Html
open Htmlfmt
open Hyper
open Www
open Document
open Maps
open Embed
open Viewers
open Fonts

let attempt_tables = ref false
let verbose = ref false

(* Interaction with other parts of the navigator interface *)
class virtual extracontext (unit) =
  virtual set_title : string -> unit
  virtual add_link : string -> Hyper.link -> unit
end

class virtual imgloader (unit) =
  virtual add_image : embobject -> unit	 (* add one image *)
  virtual flush_images : unit	         (* flush when document is loaded *)
  virtual load_images : unit		 (* manual flush *)
end

class virtual machine (unit) =
  virtual formatter : formatter
  virtual imgmanager : imgloader
  virtual tcontext : extracontext
  virtual base : string
  virtual ctx : Viewers.context
  virtual add_tag :
    string -> (formatter -> Html.tag -> unit) -> (formatter -> unit) -> unit
  virtual remove_tag : string -> unit
  virtual push_action : (string -> unit) -> unit
  virtual pop_action : unit
  virtual push_formatter : formatter -> unit
  virtual pop_formatter : unit
  virtual send : Html.token -> unit
end

(* Hooks for applets/modules. Control is made elsewhere *)
let user_hooks = ref []
let add_hook f = 
  user_hooks := f :: !user_hooks

module Make 
 (G : GfxHTML) ( I : ImgDisplay) (F: FormDisplay) (T: TableDisplay) =
struct

open G
open I
module FormLogic = Html_form.Make(G)(F)
module TableLogic = Html_table.Make(G)(T)

type anchor_type = HREF | NAME

(* Tag machinery *)

type html_behavior = {
  tag_open  : formatter -> tag -> unit;
  tag_close : formatter -> unit
  }

let ignore_open = fun _ _ -> ()
let ignore_close = fun _ -> ()


class display_machine (did, ctx, tcontext, init_fo) as self = 
    inherit machine ()
    val tags = (Hashtbl.create 101 : (string, html_behavior) Hashtbl.t)
    val mutable action = init_fo.format_string
    val mutable formatter = init_fo

    val imgmanager = I.create()
    val tcontext = tcontext
    val ctx = (ctx : Viewers.context)

    val private mutable action_stack = [init_fo.format_string]
    val private mutable formatter_stack = [init_fo]


    val mutable base = Url.string_of did.document_url
  
    (* Accessing some variables *)
    method formatter = formatter
    method imgmanager = imgmanager    
    method base = base
    method ctx = ctx
    method tcontext = tcontext

    (* Adding and removing tag behaviors *)
    method add_tag t o c = Hashtbl.add tags t {tag_open = o; tag_close = c}
    method remove_tag = Hashtbl.remove tags

    (* Changing the default mode for pcdata and cdata *)
    method push_action f =
      action_stack <-  f :: action_stack;
      action <- f
    method pop_action =
      match action_stack with
	 [] | [_] -> (* never pop the last one *)
           Log.f "Warning: empty action stack"
       | old::newa::l ->
	   action_stack <- newa::l;
	   action <- newa

    (* Nested formatters for table cells and other usage *)
    method push_formatter fo =
      formatter <- fo;
      formatter_stack <- fo :: formatter_stack;
      self#push_action fo.format_string

    method pop_formatter =
      self#pop_action;
      match formatter_stack with
	[] | [_] -> Log.f "Warning: empty formatter stack"
      | old::newa::l ->
	  old.flush();
	  formatter_stack <- newa::l;
	  formatter <- newa

    (* This is only for robustness *)
    method flush_formatters =
      while List.length formatter_stack > 1 do
	Log.f "WARNING: too many formatters in stack";
	self#pop_formatter;
	formatter.flush()
      done

    method set_base b = base <- b

    (* Dispatching a token *)
    method send = function
	EOF -> formatter.flush ()
      | CData s -> action s
      | PCData s -> action s
      | OpenTag t ->
	   begin try
	     let tag = Hashtbl.find tags t.tag_name in
	       tag.tag_open formatter t
	   with
	     Not_found ->
	       if !verbose then
		 Log.f (sprintf "Display machine: <%s> ignored" t.tag_name)
	   end
      | CloseTag n ->
	   begin try
	     (Hashtbl.find tags n).tag_close formatter
	   with
	     Not_found ->
	       if !verbose then
		 Log.f (sprintf "Display machine: </%s> ignored" n)
	   end
      | Comment _ -> ()
      | Doctype _ -> ()
end


(* Standard initialisation for HTML 2.0 (+bits of 3.2) *)
let init mach =
  (* Style abbreviation 
   * TODO?: check stack.
   *)
  let push_style fo s =
   try fo.push_attr (Styles.get s)
   with Not_found -> Log.f (sprintf "Missing style : %s" s)
  and pop_style fo s =
   try fo.pop_attr (Styles.get s)
   with Not_found -> Log.f (sprintf "Missing style : %s" s)

  in

(* 5.1 HTML *)
(* TODO: Could flush formatters ? when closing is reached *)
mach#add_tag "html"
   ignore_open
   (fun fo -> 
      fo.flush();
      mach#imgmanager#flush_images;
      mach#flush_formatters
      );

(*
 * 5.2 Head: <HEAD>
 * <!ENTITY % head.content "TITLE & ISINDEX? & BASE? %head.extra">
 * <!ENTITY % head.extra "& NEXTID?">
 *)
mach#add_tag "head" ignore_open ignore_close;

(*
 * 5.2.1 Title: <TITLE>
 * assumes a unique Text token inside since
 * <!ELEMENT TITLE - -  (#PCDATA)*>
 * the title is not printed
 *)
mach#add_tag "title" 
   (fun fo t ->
	 mach#push_action 
            (fun s -> mach#tcontext#set_title (Html.beautify2 s)))
   (fun fo -> mach#pop_action);

(*
 * 5.2.2 Base Address: <BASE>
 *)

mach#add_tag "base"
    (fun fo t -> 
       try mach#set_base (get_attribute t "href")
       with
	 Not_found -> raise (Invalid_Html "HREF required in BASE"))
    ignore_close;

(*
 * 5.2.3 Keyword Index: <ISINDEX>
 * HTML3.2: PROMPT attribute (default given)
 *)
mach#add_tag "isindex"
   (fun fo t -> fo.isindex (get_attribute t "prompt") mach#base)
   ignore_close;

(*
 * 5.2.4 Link: <LINK>
 * 5.2.5 Associated Meta-information: <META>
 * 5.2.6 Next Id: <NEXTID>
 *)
List.iter (fun t -> mach#add_tag t ignore_open ignore_close)
    ["meta"; "nextid"];

mach#add_tag "link"
   (fun fo tag ->
      try
        let href = get_attribute tag "href"  in
	let name = 
	  try get_attribute tag "title"
	  with Not_found ->
	    try get_attribute tag "rel"
	    with Not_found -> 
	       try get_attribute tag "rev"
	       with Not_found -> href
        in
        mach#tcontext#add_link name
	    {h_uri = href; h_context = Some mach#base; h_method = GET}
      with
	Not_found -> () (* no href *))
   ignore_close;

(*
 * 5.3 Body: <BODY>
 * <!ENTITY % html.content "HEAD, BODY">
 * Note: with textw_fo, flush disables the text widget, so anything
   beyond </BODY> will not be displayed. Some documents have multiple
   bodies, or </BODY> before the end of the document. So we decide
   to completely ignore this tag. A stricter interpretation would be
   {tag_open = ignore; tag_close = (fun fo -> fo.flush())};
   Our simpled minded minimization rules also introduce multiple BODY.
 *)

mach#add_tag "body" 
  (fun fo t ->
     (try
       let bgcolor = get_attribute t "bgcolor" in
	  fo.set_defaults [BgColor bgcolor]
      with
	Not_found -> ());
     (try
       let text = get_attribute t "text" in
	  fo.set_defaults [FgColor text]
      with
	Not_found -> ()))
  ignore_close;


(*
 * 5.4 Headings <H1> ... <H6>
 * <!ELEMENT ( %heading )  - -  (%text;)*>
 * Assume headings may contain typographic styles, anchors
 * HTML3.2
 * <!ATTLIST ( %heading )
 *         align  (left|center|right) #IMPLIED
 *         >
 *)

(* Private variables of header *)
let header_size = ref 0 
and header_align = ref None in

let open_header size fo tag =
  fo.new_paragraph() ;
  header_size := size;
  push_style fo (sprintf "header%d" size);
  try
    let align = get_attribute tag "align" in 
      fo.push_attr [Justification align];
      header_align := Some align
  with
    Not_found -> header_align := None

and close_header fo =
  pop_style fo (sprintf "header%d" !header_size);
  fo.close_paragraph();
  match !header_align with
    None -> ()
  | Some a -> fo.pop_attr [Justification a]

in

List.iter (function headnum ->
	     mach#add_tag (sprintf "h%d" headnum)
		  (open_header headnum)
		  close_header)
      	  [1;2;3;4;5;6];

(*
 * 5.5.1 Paragraph: <P>
 *   a bit approximative in HTML 2.0
 * HTML3.2
 * <!ATTLIST P
 *         align  (left|center|right) #IMPLIED
 *         >
 *)
let paligns = ref [] in

mach#add_tag "p" 
  (fun fo tag -> 
     fo.new_paragraph ();
     try
       let a = get_attribute tag "align" in
	 paligns := (Some a) :: !paligns;
	 fo.push_attr [Justification a]
     with
       Not_found -> paligns := None :: !paligns)
  (fun fo ->
     fo.close_paragraph();
     match !paligns with
       [] -> () (* that's an error actually *)
     | (Some a)::l ->
	 fo.pop_attr [Justification a];
	 paligns := l
     | None::l ->
	 paligns := l
    );

(* 
 * 5.5.2 Preformatted Text : <PRE>
 *    TODO: optional attribute WIDTH
 *    should be fixed font, respecting newlines
 *    local styles authorized however (i.e. markup is parsed)
*)
let open_pre fo tag =
  fo.new_paragraph();
  push_style fo "verbatim";
  mach#push_action fo.print_verbatim
and close_pre fo =
  pop_style fo "verbatim";
  fo.close_paragraph();
  mach#pop_action

in
(* 5.5.2.1 Example and Listing: <XMP>, <LISTING>
 *    deprecated anyway
 *)

List.iter (function s -> mach#add_tag s open_pre close_pre)
          ["pre"; "listing"; "xmp"];

(*
 * 5.5.3 Address: <ADDRESS>
 *)
mach#add_tag "address" 
   (fun fo tag -> fo.new_paragraph(); push_style fo "italic")
   (fun fo -> pop_style fo "italic"; fo.close_paragraph());

(*
 * 5.5.4 Block Quote: <BLOCKQUOTE>
 *)
mach#add_tag "blockquote"
   (fun fo tag ->
      fo.new_paragraph();
      push_style fo "italic";
      fo.push_attr [Margin 10])
   (fun fo ->
      pop_style fo "italic";
      fo.pop_attr [Margin 10];
      fo.close_paragraph());

(*
 * 5.6.1 Unordered List: <UL>, <LI>
 * HTML3.2 
 * <!ENTITY % ULStyle "disc|square|circle">
 * 
 * <!ATTLIST UL -- unordered lists --
 *         type    (%ULStyle)   #IMPLIED   -- bullet style --
 *         compact (compact)    #IMPLIED   -- reduced interitem spacing --
 *         >
 * TODO: inter item spacing
 *)

let list_level = ref 0 in
let open_list fo tag =
  fo.push_attr [Margin 10];
  incr list_level;
  let bullet = 
    try get_attribute tag "type" 
    with Not_found ->
       match !list_level mod 3 with
         1 -> "disc" | 2 -> "circle" | _ -> "square" in
  let compact = has_attribute tag "compact"
  and first_line = ref true in
  fo.new_paragraph();
  mach#add_tag "li"
     (fun fo tag -> 
        if !first_line then first_line := false
	else if compact then fo.print_newline false else fo.new_paragraph();
        let bullet = try get_attribute tag "type" with Not_found -> bullet in
	fo.bullet bullet)
     (fun fo -> 
        if not compact then fo.close_paragraph())

and close_list fo =
  decr list_level;
  fo.close_paragraph();
  fo.pop_attr [Margin 10];
  mach#remove_tag "li"
in

mach#add_tag "ul" open_list close_list;

(* 
 * 5.6.2 Ordered List: <OL>, <LI>
 * HTML3.2
 * <!--
 *        Numbering style
 *     1   arablic numbers     1, 2, 3, ...
 *     a   lower alpha         a, b, c, ...
 *     A   upper alpha         A, B, C, ...
 *     i   lower roman         i, ii, iii, ...
 *     I   upper roman         I, II, III, ...
 * 
 *     The style is applied to the sequence number which by default
 *     is reset to 1 for the first list item in an ordered list.
 * -->
 * 
 * <!ENTITY % OLStyle "CDATA" -- "1|a|A|i|I" but SGML folds case -->
 * 
 * <!ATTLIST OL -- ordered lists --
 *         type     (%OLStyle)  #IMPLIED   -- numbering style --
 *         start     NUMBER     #IMPLIED   -- starting sequence number --
 *         compact  (compact)   #IMPLIED   -- reduced interitem spacing --
 *         >
 *)

let numbering_styles =
  ["1", string_of_int;
   "a", (function i -> String.make 1 (Char.chr (96+i)));
   "A", (function i -> String.make 1 (Char.chr (64+i)));
   "i", (* TODO: make that correct roman.
           Currently: engineer interpretation of ... *)
        (function i -> String.make i 'i');
   "I",  (function i -> String.make i 'I')
  ]
in

let open_nlist, close_nlist =
  let nesting = ref [] in
  (* open_list *)
  (fun fo tag ->
    let li_counter = ref (try int_of_string (get_attribute tag "start")
                          with _ -> 0) in
     fo.push_attr [Margin 10];
     nesting := li_counter :: !nesting;
     let thisnumbers = List.rev !nesting
     and numbering = 
       try List.assoc (get_attribute tag "type") numbering_styles 
       with Not_found -> string_of_int
     and compact = has_attribute tag "compact" in
     mach#add_tag "li"
       (fun fo tag ->
	  fo.new_paragraph();
	  if compact then fo.push_attr [Spacing 0];
	  incr li_counter;
	  List.iter (function i ->
			fo.format_string (numbering !i);
			fo.format_string ".")
		    thisnumbers)
       (fun fo ->
	  if compact then fo.pop_attr [Spacing 0];
	  fo.close_paragraph())),
  (* close_list *)
  (fun fo ->
    fo.pop_attr [Margin 10];
    nesting := begin match !nesting with [] -> [] | x::l -> l end;
    mach#remove_tag "li")
  in

mach#add_tag "ol" open_nlist close_nlist;

(*
 * 5.6.3 Directory List: <DIR>
 * 5.6.4 Menu List: <MENU>
 *  do as <UL>, but we should work on presentation
 *)

mach#add_tag "dir" open_list close_list;
mach#add_tag "menu" open_list close_list;

(*
 * 5.6.5 Definition List: <DL>, <DT>, <DD> 
 *)
let open_dl, close_dl =
  (* open_dl *)
  (fun fo tag ->
    let compact = has_attribute tag "compact" in
      fo.new_paragraph();
      fo.push_attr [Margin 10];
      if not compact then begin
      let prev_is_dt = ref false in
	mach#add_tag "dt"
	  (fun fo tag -> 
	    if not !prev_is_dt then begin
	      fo.new_paragraph();
	      prev_is_dt := true
	     end
	    else fo.print_newline false;
	    push_style fo "bold")
	  (fun fo -> pop_style fo "bold");
	mach#add_tag "dd"
	  (fun fo tag ->
	      if !prev_is_dt then begin
		fo.close_paragraph();
		prev_is_dt := false
	       end;
	      fo.new_paragraph();
	      fo.push_attr [Margin 20])
	  (fun fo ->
	      fo.pop_attr [Margin 20];
	      fo.close_paragraph())
       end
      else begin
	let first_item = ref true in
	mach#add_tag "dt"
	  (fun fo tag -> 
	    if not !first_item then fo.print_newline false
            else first_item := false;
            push_style fo "bold")
	  (fun fo -> pop_style fo "bold");
	mach#add_tag "dd"
	  (fun fo tag ->
	    if not !first_item then fo.print_newline false
            else first_item := false;
	    fo.push_attr [Margin 20])
	  (fun fo -> fo.pop_attr [Margin 20])
       end),
   (* close_dl *)
   (fun fo ->
      fo.pop_attr [Margin 10];
      fo.close_paragraph();
      mach#remove_tag "dt";
      mach#remove_tag "dd")
in

mach#add_tag "dl" open_dl close_dl;

(* Different typographic styles, shared *)
let italic_style t = 
  mach#add_tag t 
     (fun fo tag -> push_style fo "italic")
     (fun fo -> pop_style fo "italic")
and fixed_style t =
  mach#add_tag t 
    (fun fo tag -> push_style fo "fixed")
    (fun fo -> pop_style fo "fixed")
and bold_style t =
  mach#add_tag t 
    (fun fo tag -> push_style fo "bold")
    (fun fo -> pop_style fo "bold")
in

(*
 * 5.7.1.1 Citation: <CITE>
 * 5.7.1.2 Code: <CODE>
 * 5.7.1.3 Emphasis: <EM>
 * 5.7.1.4 Keyboard: <KBD>
 * 5.7.1.5 Sample: <SAMP>
 * 5.7.1.6 Strong Emphasis: <STRONG>
 * 5.7.1.7 Variable: <VAR>
 *)

List.iter italic_style ["cite"; "em"; "var"];
List.iter fixed_style ["code"; "kbd"; "samp"];
bold_style "strong";
(*
 * 5.7.2.1 Bold: <B>
 * 5.7.2.2 Italic: <I>
 * 5.7.2.3 Teletype: <TT>
 *)
bold_style "b";
italic_style "i";
fixed_style "tt";

(*
 * 5.7.3 Anchor: <A> 
 * Assumes anchors are not nested
 * Can be both HREF and NAME.
 *)

let anchor_type = ref None
and anchor_link = 
  ref {h_uri = ""; h_context = None; h_method = GET}
and in_anchor = ref false
in
let open_anchor fo tag =
  anchor_type := None;
  (* is there a NAME attribute ? *)
  begin
     try 
       fo.add_mark (get_attribute tag "name");
       anchor_type := Some NAME
     with 
       Not_found -> ()
  end;
  (* is there an HREF attribute ? (if both, anchor_type is set to HREF *)
  (* so that close_anchor does the right thing) *)
  begin
    try
      let href = get_attribute tag "href" in
      anchor_link := 
	{ h_uri = href;
	  h_context = Some mach#base;
	  h_method = 
	     (try parse_method (get_attribute tag "methods")
	      with _ -> GET)};
      in_anchor := true;
      anchor_type := Some HREF;
      fo.start_anchor ();
      push_style fo "anchor"
    with
      Not_found ->
	match !anchor_type with
	  None -> raise (Invalid_Html "Missing NAME or HREF in <A>")
	| _ -> ()
  end

and close_anchor fo =
  match !anchor_type with
    Some HREF -> 
      fo.end_anchor !anchor_link;
      pop_style fo "anchor";
      in_anchor := false;
      anchor_type := None
 |  Some NAME ->
      in_anchor := false;
      anchor_type := None
 |  None -> raise (Invalid_Html "Unmatched </A>")

in

mach#add_tag "a" open_anchor close_anchor;

(*
 * 5.8 Line break: <BR> 
 *)
mach#add_tag "br" 
    (fun fo tag ->
      fo.print_newline true)
    ignore_close;

(*
 * 5.9 Horizontal Rule: <HR>
 *)
mach#add_tag "hr"
    (fun fo tag -> fo.print_newline false; fo.hr (); fo.print_newline false)
    ignore_close;

(*
 * 5.10 Image: <IMG>
 *)

mach#add_tag "img"
    (fun fo tag -> 
      try
       let align = get_attribute tag "align"
       and width = 
	 try Some (int_of_string (get_attribute tag "width"))
	 with Not_found | Failure "int_of_string" -> None
       and height = 
	 try Some (int_of_string (get_attribute tag "height"))
	 with Not_found | Failure "int_of_string" -> None
       and alt = get_attribute tag "alt"
       in          
       let w = fo.create_embedded align width height in
       let src = get_attribute tag "src" in
       let link =
	  {h_uri = src; h_context = Some mach#base; h_method = GET} in
       (* some people use both ismap and usemap...
          prefer usemap
        *)
       let map = 
	 try 
	   let mapname = get_attribute tag "usemap"  in
	     Maps.ClientSide {h_uri = mapname;
			      h_context = Some mach#base; h_method = GET}
	 with Not_found -> 
	   if !in_anchor then
	     if has_attribute tag "ismap"
	     then Maps.ServerSide !anchor_link
	     else Maps.Direct !anchor_link
	   else NoMap
       and ctx = {
         viewer_base = mach#ctx.viewer_base ;
         viewer_hyper = mach#ctx.viewer_hyper;
         viewer_log = mach#ctx.viewer_log;
         viewer_params = tag.attributes
         } in
       mach#imgmanager#add_image  
		    {embed_hlink = link;
		     embed_frame = w;
		     embed_context = ctx;
		     embed_map = map;
		     embed_alt = alt}
      with
       Not_found -> (* only on SRC *)
	raise (Invalid_Html "missing SRC in IMG"))
   ignore_close;

(* FORMS: they are defined elsewhere (html_form) *)
  FormLogic.init mach;
(* standard basic HTML2.0 initialisation stops here *)

(* TABLE support *)
  if !attempt_tables then TableLogic.init mach
  else begin
    let behave_as oldtag newtag =
      mach#add_tag newtag
	(fun fo t -> mach#send (OpenTag {tag_name = oldtag; attributes = []}))
	(fun fo -> mach#send (CloseTag oldtag)) in
    (* use DL for tables *)
    behave_as "dl" "table";
    mach#add_tag "tr" ignore_open ignore_close;
    behave_as "dt" "th";
    behave_as "dd" "td"
    end;

(* EMBED
 *  The definition is a mix of what was done for earlier versions
 *  of MMM and Netscape Navigator. The reason is to get compatible HTML for
 *  Caml Applets in both browsers.
 *)

  mach#add_tag "embed"
    (fun fo tag -> 
       try
	 let link = {
	   h_uri = get_attribute tag "src";
	   h_method = GET;
	   h_context = Some mach#base } in
	 let width =
	   try Some (int_of_string (get_attribute tag "width"))
	   with Not_found -> None
	 and height =
	   try Some (int_of_string (get_attribute tag "height"))
	   with Not_found -> None
	 and alttxt = get_attribute tag "alt" in

	 let fr = fo.create_embedded "" width height 
	 and ctx = {
	   viewer_base = mach#ctx.viewer_base;
	   viewer_hyper = mach#ctx.viewer_hyper;
	   viewer_log = mach#ctx.viewer_log;
	   viewer_params = tag.attributes
	   }  in
	 Embed.add {
	     embed_hlink = link;
	     embed_frame = fr;
	     embed_context = ctx;
	     embed_map = NoMap; (* yet *)
	     embed_alt = alttxt
	    }
       with
	 Not_found ->
	   raise (Invalid_Html ("SRC missing in EMBED")))
    ignore_close;

  (* Some HTML 3.2 obnoxious features *)
  mach#add_tag "script" 
      (fun fo t -> mach#push_action (fun s -> ()))
      (fun fo -> mach#pop_action);
  mach#add_tag "style" 
      (fun fo t -> mach#push_action (fun s -> ()))
      (fun fo -> mach#pop_action);
  (* Some HTML 3.2 flashy features *)
  mach#add_tag "center"
      (fun fo t -> fo.push_attr [Justification "center"])
      (fun fo -> fo.pop_attr [Justification "center"]);
  mach#add_tag "div"
      (fun fo t -> fo.push_attr [Justification (get_attribute t "align")])
      (fun fo -> fo.pop_attr [Justification "whocares"]);
  mach#add_tag "big"
      (fun fo t -> fo.push_attr [Font (FontDelta 2)])
      (fun fo  -> fo.pop_attr [Font (FontDelta 2)]);
  mach#add_tag "small"
      (fun fo t -> fo.push_attr [Font (FontDelta (-2))])
      (fun fo  -> fo.pop_attr [Font (FontDelta (-2))]);
  mach#add_tag "u"
      (fun fo t -> fo.push_attr [Underlined])
      (fun fo  -> fo.pop_attr [Underlined]);
  mach#add_tag "strike"
      (fun fo t -> fo.push_attr [Striked])
      (fun fo  -> fo.pop_attr [Striked]);
  mach#add_tag "sup"
      (fun fo t -> fo.push_attr [Superscript])
      (fun fo  -> fo.pop_attr [Superscript]);
  mach#add_tag "sub"
      (fun fo t -> fo.push_attr [Lowerscript])
      (fun fo  -> fo.pop_attr [Lowerscript]);
  let fontchanges = ref [] in
  mach#add_tag "font"
      (fun fo t ->
	 let attrs = [] in
	 let attrs =
	   try
             let size = get_attribute t "size" in
             let l = String.length size in
	       if l = 0 then raise Not_found
	       else if size.[0] = '+' then
		(Font (FontDelta (int_of_string (String.sub size 1 (pred l)))))
                     :: attrs
               else if size.[0] = '-' then
		     (Font (FontDelta (int_of_string size)))::attrs
               else (Font (FontIndex (int_of_string size)))::attrs
	   with 
	      Not_found -> attrs 
            | Failure _ -> attrs
	   in
         let attrs = 
	   try
	     let color = get_attribute t "color" in
               (FgColor color)::attrs
	   with Not_found -> attrs in
          if attrs = [] then ()
	  else (fo.push_attr attrs; fontchanges := attrs :: !fontchanges))
      (fun fo -> 
	 match !fontchanges with
	  [] -> raise (Invalid_Html "unmatched </font>")
        | x::l -> fontchanges := l; fo.pop_attr x);

  (* Some HTML 3.2 good features *)
  let areas = ref []
  and mapname = ref ""
  in
  mach#add_tag "map"
      (fun fo t ->
         (* the name of the map *)
         let absname = 
           try 
	    let name = get_attribute t "name" in
	      sprintf "%s#%s" mach#base name
           with
	     Not_found -> mach#base
         in
         mapname := absname;
         areas := [];
         mach#add_tag "area" 
	    (fun fo tag -> 
	       let shape = Mstring.lowercase (get_attribute tag "shape")
	       and href = 
		 try Some (get_attribute tag "href") with Not_found -> None
               and coords =
		 try Maps.parse_coords (get_attribute tag "coords")
		 with _ -> [] 
               and alttxt =
                 try get_attribute tag "alt" with Not_found -> ""
               in
               match href with
		 None -> () (* this creates a HOLE. not yet supported *)
	       | Some uri ->
		  let link = {h_uri = uri; h_context = Some mach#base;
			      h_method = GET} in
                  let area = 
		    match shape with
		     "default" -> {area_kind = Default; area_coords =[];
				   area_link = link; area_alt = alttxt}
		   | "rect" -> {area_kind = Rect; area_coords = coords;
				area_link = link; area_alt = alttxt}
		   | "circle" -> {area_kind = Circle; area_coords = coords;
				  area_link = link; area_alt = alttxt}
		   | "poly" -> {area_kind = Poly; area_coords = coords;
				area_link = link; area_alt = alttxt} 
		   | _ -> {area_kind = Default; area_coords =[];
				   area_link = link; area_alt = alttxt} in
                  areas := area :: !areas)
            ignore_close)
 
     (fun fo -> 
	 mach#remove_tag "area";
	 Maps.add !mapname !areas)



let create (did, ctx, tcontext, init_fo) =
 let mach = new display_machine (did, ctx, tcontext, init_fo) in
   init mach;
   List.iter (fun f -> f (mach :> machine)) !user_hooks;
   (mach :> machine)

end

