(* Html *)
(* $Id: html.ml,v 1.8 2001/03/06 19:13:59 berke Exp $ *)
(* Petit module de output HTML *)
(* par Berke Durak *)
(* 20001104 *)

let sf = Printf.sprintf;;

let char_array_to_char_table a =
  let b = Array.make 256 None in
  for i = 0 to Array.length a - 1 do
    let (c,s) = a.(i) in
    b.(Char.code c) <- Some ("&"^s^";")
  done;
  b
;;
    
(* Ce tableau de conversion a été engendré avec la commande *)
(* zcat /usr/doc/doc-rfc/all-included-rfcs/rfc1866.txt.gz | perl -e 'while(<STDIN>){if(/^\<\!ENTITY\s+(\w+)\s+CDATA\s+\"\&\#(\d+)\;/){printf "    \047\\%03d\047, \"$1\"\;\n",$2}}' *)
(* Découlant directement des Tes Sacrés, il ne peut contenir d'erreur. *)

(*** iso_8859_1_array *)
let iso_8859_1_array =
  [|
    '\038', "amp";
    '\062', "gt";
    '\060', "lt";
    '\034', "quot";
    '\198', "AElig";
    '\193', "Aacute";
    '\194', "Acirc";
    '\192', "Agrave";
    '\197', "Aring";
    '\195', "Atilde";
    '\196', "Auml";
    '\199', "Ccedil";
    '\208', "ETH";
    '\201', "Eacute";
    '\202', "Ecirc";
    '\200', "Egrave";
    '\203', "Euml";
    '\205', "Iacute";
    '\206', "Icirc";
    '\204', "Igrave";
    '\207', "Iuml";
    '\209', "Ntilde";
    '\211', "Oacute";
    '\212', "Ocirc";
    '\210', "Ograve";
    '\216', "Oslash";
    '\213', "Otilde";
    '\214', "Ouml";
    '\222', "THORN";
    '\218', "Uacute";
    '\219', "Ucirc";
    '\217', "Ugrave";
    '\220', "Uuml";
    '\221', "Yacute";
    '\225', "aacute";
    '\226', "acirc";
    '\230', "aelig";
    '\224', "agrave";
    '\229', "aring";
    '\227', "atilde";
    '\228', "auml";
    '\231', "ccedil";
    '\233', "eacute";
    '\234', "ecirc";
    '\232', "egrave";
    '\240', "eth";
    '\235', "euml";
    '\237', "iacute";
    '\238', "icirc";
    '\236', "igrave";
    '\239', "iuml";
    '\241', "ntilde";
    '\243', "oacute";
    '\244', "ocirc";
    '\242', "ograve";
    '\248', "oslash";
    '\245', "otilde";
    '\246', "ouml";
    '\223', "szlig";
    '\254', "thorn";
    '\250', "uacute";
    '\251', "ucirc";
    '\249', "ugrave";
    '\252', "uuml";
    '\253', "yacute";
    '\255', "yuml";
  |];;
(* ***)
      
let iso_8859_1_table = char_array_to_char_table iso_8859_1_array
let iso_8859_1_table_sans_guillements =
  let a = Array.copy iso_8859_1_table in
  a.(Char.code '"') <- Some "&quot;";
  a
;;
let iso_8859_1_table_nl_to_br =
  let a = Array.copy iso_8859_1_table in
  a.(Char.code '\n') <- Some "<BR>\n";
  a
;;

type html_document =
  { head: html_head;
    body: html_element }
and html_head =
  { title: string;
    author: string;
    charset: html_charset;
    style_sheet: string option }
and html_charset = ASCII | ISO_8859_1 | UTF8
and html_method = GET | POST
and html_element =
| I_button of string * string (* name, value *)
| I_hidden of string * string
| I_text of string * string * int option * int option (* name, value, size, maxlength *)
| I_text_area of string * int * int * string
| I_checkbox of string * string * bool
| I_radio of string * string * bool
| I_select of string * bool * int * (string * string * bool) list
| I_reset of string
| Form of html_method * string * html_element
| Anchor of url * html_element
| Seq of html_element list
| UL of html_element list
| P of html_element
| H of int * html_element
| T of string (* ISO-8859-1 text *)
| BT of string (* ISO-8859-1 text *)
| IT of string (* ISO-8859-1 text *)
| TT of string (* ISO-8859-1 text *)
| Pre of string (* pre-formatted text *)
| HR
| Table of html_table_row list
| Nop
| BR
| Div of string * html_element list
| Span of string * html_element
and html_table_row = html_table_cell list
and html_table_cell =
| C_contents of html_element
| C_halign of html_table_cell_halign * html_table_cell
| C_valign of html_table_cell_valign * html_table_cell
| C_rowspan of int * html_table_cell
| C_colspan of int * html_table_cell
| C_header of html_table_cell
| C_color of Rgb.t * html_table_cell
and html_table_cell_halign =
| Cha_left
| Cha_center
| Cha_right
| Cha_justify
| Cha_char of char
and html_table_cell_valign =
| Cva_top
| Cva_middle
| Cva_bottom
| Cva_baseline
and url = string
;;

let default_head =
  { title = "Untitled";
    author = "Ara HTTPD";
    charset = ISO_8859_1;
    style_sheet = None }
;;

let string_of_charset = function
  | ASCII -> "ascii"
  | ISO_8859_1 -> "iso-8859-1"
  | UTF8 -> "utf8"
;;

let output (f : string -> unit) (fc : char -> unit) x =
  let indent = ref 0 in
  let put_indent () =
    for i = 1 to !indent do
      f "  "
    done
  in
  let text_avec_table t y =
    for i = 0 to String.length y - 1 do
      let c = y.[i] in
      match t.(Char.code c) with
      |	None -> fc c
      |	Some u -> f u
    done
  in
  let text = text_avec_table iso_8859_1_table and
      text_without_quotes = text_avec_table iso_8859_1_table_sans_guillements in
  let gui = text_without_quotes in
  let ife f = function
    | Some x -> ignore (f x)
    | None -> () in
  let launch_tag x =
    put_indent ();
    f ("<"^x)
  and flush_tag () =
    f ">\n";
    incr indent
  and flush_linear_tag () =
    f ">\n"
  and flush_tag_without_nl () =
    f ">";
  and end_tag x =
    decr indent;
    put_indent ();
    f ("</"^x^">\n")
  and end_tag_linear x =
    f ("</"^x^">\n")
  in
  let start_tag x =
    launch_tag x;
    flush_tag ()
  and start_tag_lineaire x =
    launch_tag x;
    flush_linear_tag ()
  and start_tag_without_nl x =
    launch_tag x;
    flush_tag_without_nl ()
  in
  let linear_tag x =
    launch_tag x;
    flush_linear_tag ()
  in
  let rec cellule c i j =
    let rec loop he ha va rs cs rgb c =
      match c with
      |	C_header (c) -> loop true ha va rs cs rgb c
      | C_halign (ha,c) -> loop he (Some ha) va rs cs rgb c
      | C_valign (va,c) -> loop he ha (Some va) rs cs rgb c
      | C_rowspan (rs,c) -> loop he ha va (Some rs) cs rgb c
      | C_colspan (cs,c) -> loop he ha va rs (Some cs) rgb c
      |	C_color (rgb,c) -> loop he ha va rs cs (Some rgb) c
      | C_contents e ->
	  launch_tag (if he then "TH" else "TD");
	  begin
	    let coefficient_parity_row = -2
	    and coefficient_parity_column = -1
	    and coefficient_head = -4
	    and shift = 11
	    and coefficient_total = 12
	    in
	    match rgb with
	      Some(rgb) ->
		f (Printf.sprintf " BGCOLOR=\"%s\""
		     (Rgb.to_string
			(let alpha =
			  (float_of_int
			     (((if he then 0 else coefficient_head)
				 + coefficient_parity_row * (i mod 2)
				 + coefficient_parity_column * (j mod 2)) + shift)) /.
			  (float_of_int coefficient_total)
			in
			Rgb.mix alpha Rgb.white rgb)));
	    | _ -> ()
	  end;
	  ife
	      (fun ha ->
		f " ALIGN=";
		match ha with
		| Cha_left -> f "LEFT"
		| Cha_center -> f "CENTER"
		| Cha_right -> f "RIGHT"
		| Cha_justify -> f "JUSTIFY"
		| Cha_char c -> f "\""; gui (String.make 1 c); f "\"")
	      ha;
	  ife
	      (fun va ->
		f " VALIGN=";
		match va with
		| Cva_top -> f "TOP"
		| Cva_middle -> f "MIDDLE"
		| Cva_bottom -> f "BOTTOM"
		| Cva_baseline -> f "BASELINE")
	      va;
	  ife (fun rs -> f (" ROWSPAN="^(string_of_int rs))) rs;
	  ife (fun cs -> f (" COLSPAN="^(string_of_int cs))) cs;
	  flush_tag ();
	  element e;
	  end_tag (if he then "TH" else "TD")
    in
    loop false None None None None None c
  and element y =
    match y with
    | Anchor(u,e) ->
	launch_tag "A";
	f " HREF=\"";
	gui u;
	f "\"";
	flush_tag ();
	element e;
	end_tag "A"
    | Form (m,u,e) ->
	launch_tag "FORM";
	f (" METHOD="^(match m with POST -> "POST" | GET -> "GET")^" ACTION=\"");
	f u;
	f "\" ENCTYPE=\"application/x-www-form-urlencoded\"";
	flush_tag ();
	element e;
	end_tag "FORM";
    | Div(c, z) ->
        launch_tag "DIV";
        f (sf " CLASS=%S" c);
        flush_tag ();
        List.iter (fun t -> element t) z;
        end_tag "DIV"
    | Span(c, z) ->
        launch_tag "SPAN";
        f (sf " CLASS=%S" c);
        flush_tag ();
        element z;
        end_tag "SPAN"
    | Seq z -> List.iter (fun t -> element t) z
    | UL l ->
	start_tag "UL";
	List.iter (fun t ->
	  start_tag "LI";
	  element t;
	  end_tag "LI") l;
	end_tag "UL"
    | H(i, z) ->
	start_tag ("H"^(string_of_int i));
	element z;
	end_tag ("H"^(string_of_int i))
    | T z ->
	put_indent ();
	text_avec_table iso_8859_1_table_nl_to_br z;
	f "\n"
    | BT z -> start_tag "B"; text z; end_tag "B"
    | TT z -> start_tag "TT"; text z; end_tag "TT"
    | IT z -> start_tag "I"; text z; end_tag "I"
    | Pre z ->
	start_tag_without_nl "PRE"; text z;
	end_tag_linear "PRE"
    | HR -> linear_tag "HR"
    | BR -> linear_tag "BR"
    | P z -> linear_tag "P"; element z (* start_tag "P"; element z; end_tag "P" *)
    | Nop -> f " "
    | I_select (n,m,s,l) ->
	launch_tag "SELECT";
	f " SIZE="; f (string_of_int s);
	f " NAME=\""; gui n; f (if m then "\" MULTIPLE" else "\"");
	flush_tag ();
	List.iter (fun (n,v,s) ->
	  launch_tag "OPTION";
	  f " VALUE=\""; gui n; f (if s then "\" SELECTED" else "\"");
	  flush_linear_tag ();
	  text v;
	  f " ") l;
	end_tag "SELECT"
    | I_reset (v) ->
	launch_tag "INPUT";
	f " TYPE=RESET VALUE=\""; gui v; f "\"";
	flush_linear_tag ()
    | I_button (n,v) ->
	launch_tag "INPUT";
	f " TYPE=SUBMIT NAME=\""; gui n; f "\" VALUE=\""; gui v; f "\"";
	flush_linear_tag ()
    | I_hidden (n,v) ->
	launch_tag "INPUT";
	f " TYPE=HIDDEN NAME=\""; gui n; f "\" VALUE=\""; gui v; f "\"";
	flush_linear_tag ()
    | I_text (n,v,s,m) ->
	launch_tag "INPUT";
	f " TYPE=TEXT NAME=\""; gui n; f "\" VALUE=\""; gui v; f "\"";
	begin
	  match s with
	  | Some(s) -> f (" SIZE="^(string_of_int s))
	  | None -> ();
	end;
	begin
	  match m with
	  | Some(m) -> f (" MAXLENGTH="^(string_of_int m))
	  | None -> ();
	end;
	flush_linear_tag ()
    | I_text_area (n,r,c,v) ->
	launch_tag "TEXTAREA";
	f (Printf.sprintf " ROWS=%d COLS=%d NAME=\"" r c); gui n; f "\"";
	flush_linear_tag ();
	text v;
	end_tag_linear "TEXTAREA"
    | I_checkbox (n,v,c) ->
	launch_tag "INPUT";
	f " TYPE=CHECKBOX NAME=\""; gui n; f "\" VALUE=\""; gui v;
	f "\"";
	if c then f " CHECKED";
	flush_linear_tag ();
    | I_radio (n,v,c) ->
	launch_tag "INPUT";
	f " TYPE=RADIO NAME=\""; gui n; f "\" VALUE=\""; gui v;
	f "\"";
	if c then f " CHECKED";
	flush_linear_tag ();
    | Table l ->
	start_tag "TABLE";
	let (i,j) = (ref 0, ref 0) in
	List.iter
	  (fun r ->
	    start_tag "TR";
	    j := 0;
	    List.iter (fun r' -> cellule r' !i !j; incr j) r;
	    incr i;
	    end_tag "TR") l;
	end_tag "TABLE"
  in
  begin
    f "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n";
    start_tag "HTML";
    begin
      start_tag "HEAD";
      (* title *)
      begin
	start_tag_without_nl "TITLE";
	text x.head.title;
	end_tag_linear "TITLE";
        (* css *)
        begin
          match x.head.style_sheet with
          | None -> ()
          | Some css ->
            launch_tag "LINK";
            f " REL=\"stylesheet\" TYPE=\"text/css\" HREF=\"";
            text_without_quotes css;
            f "\"";
            flush_linear_tag ()
        end;
        (* meta *)
	begin
	  launch_tag "META";
	  f (sf " HTTP-EQUIV=\"Content-Type: text/html; charset=%s\""
                (string_of_charset x.head.charset));
	  flush_linear_tag ();

	  launch_tag "META";
	  f " NAME=\"Author\" CONTENT=\"";
	  text_without_quotes x.head.author;
	  f "\"";
	  flush_linear_tag ()

	end;
      end;
      end_tag "HEAD";
    end;
    (* body *)
    begin
      start_tag "BODY";
      element x.body;
      end_tag "BODY";
    end;
    end_tag "HTML";
  end
;;
    
let output_to_channel oc = output (output_string oc) (output_char oc);;
let output_to_buffer b x = output (Buffer.add_string b) (Buffer.add_char b) x;;
