Previous Up Next

2.5  Module Print implementation

2.5.1  Basic printers



open Analyze
open Format

let tab = 1

let print_href h =
  open_box tab;
    print_string ("<dt><a href=\""^h.href_url^"\">");
    print_cut ();
    print_string h.href_contenu;
    print_cut ();
    print_string "</a></dt>";
  close_box ()

let print_header h =
  open_box tab;
    print_string ("");
    print_cut ();
    print_string h.hd_contenu;
    print_space ();
    print_string h.hd_description;
    print_cut ();
    print_string ("");
  close_box ()

let rec print_liste l =
  open_box tab;
    print_string "<dt>";
    print_cut ();
    print_header l.l_header;
    print_cut ();
    print_string "</dt>";
    print_cut ();
    print_string "<dd><dl>";
    open_vbox 0;
      print_cut ();
      List.iter print_ligne l.l_refs;
    close_box ();
    print_string "</dl></dd>";
  close_box ()
and print_ligne li =
  open_box tab;
    begin
      match li with
          Href h -> print_href h
        | Liste l -> print_liste l
        | Separator -> print_string "<hr>"
        | Filtered_out -> print_string "<dt>Filtered out</dt>"
    end;
  close_box ();
  print_cut ()

let print_htmldoc d =
  open_vbox 0;
    List.iter print_string d.meta;
    print_string ("<title>"^d.titre^"</title>");
    print_cut ();
    print_string ("<h1>"^d.titre^"</h1>");
    print_cut ();
    print_string "<dl>";
    print_cut ();
    List.iter print_ligne d.bmk;
    print_cut ();
    print_string "</dl>";
    print_cut ();
    print_string d.footer;
  close_box ()



2.5.2  Hierarchy production

Headings generation.


type entête = {enom : string; enum : int}
type fichier = {tête : entête list; corps : ligne list}

let name_of_entête = function
      [] -> "index.html"
    | l ->
        let rec name = function
            [] -> ""
          | t::q -> (name q)^"_"^(string_of_int t.enum)
        in (name l)^".html"

let print_entête f e =
  let rec refer f = function
      [] -> ()
    | t::q -> begin
          (refer f q);
          pp_print_string f "<a href=\"";
          pp_print_string f (name_of_entête (t::q));
          pp_print_string f "\">";
          pp_print_string f t.enom;
          pp_print_string f "</a> >";
          pp_print_space f ()
      end
  in match e with
      [] -> pp_print_string f "<p>[Top]</p>"
    | _ -> pp_open_box f 2;
        pp_print_string f "<p><a href=\"index.html\">[Top]</a> >";
        pp_print_space f ();
        refer f (List.tl e);
        pp_print_space f ();
        pp_print_string f (List.hd e).enom;
        pp_print_string f "</p>";
        pp_close_box f ()



2.5.3  File description set generation

The parcours creates the set of file descriptions (type fichier) to generate.


module Files =
    Set.Make (struct
                type t = fichier
                let compare = compare
              end)

class compteur =
  object
    val mutable c = 0
    method get = c <- c + 1; c
  end

let rec tronque p lignes =
  if p = 1 then
    List.map
      (function
           Liste l -> Liste {l_header = l.l_header;
                             l_refs = []}
         | l -> l)
      lignes
  else List.map
    (function
         Liste l -> Liste {l_header = l.l_header;
                           l_refs = (tronque (p-1) l.l_refs)}
       | l -> l)
    lignes

let rec parcours set p entête lignes =
  let c = new compteur in
    List.fold_left
      (fun set ligne -> match ligne with
           Liste l ->
             parcours set p
               ({enom = l.l_header.hd_contenu; enum = c#get}::entête)
               l.l_refs
         | _ -> set)
      (Files.add {tête = entête; corps = tronque p lignes} set)
      lignes



2.5.4  Circular list of colors


class virtual duplicatable =
  object (_ : 'a)
    method virtual dup : 'a
  end

class color (c_init : string) =
  object (self)
    inherit duplicatable
    val c = c_init
    method col = c
    method dup = Oo.copy self
  end



We need to use a dup method to be able to physically replicate the list. If we just use Oo.copy, the internal queue is shared between the two copies. This is needed to have a consistent look for all the files.


class ['a] circular_list =
  object (self)
    inherit duplicatable
    constraint 'a = #duplicatable
    val mutable cols : ('a Queue.t) option = None
    method add c = match cols with
        Some q -> Queue.add c q
      | None ->
          cols <- Some (Queue.create ());
          self#add c
    method next = match cols with
        None -> raise Queue.Empty
      | Some q ->
          let c = Queue.take q in
            self#add c;
            c
    method get = match cols with
        None -> raise Queue.Empty
      | Some q -> Queue.peek q
    method dup =
      let d = Oo.copy self in
        d#clear;
        match cols with
            None -> d
          | Some q ->
              for i = 1 to Queue.length q do
                d#add self#next#dup
              done;
              d
    method clear = cols <- None
 end

type colors = (color circular_list) circular_list



2.5.5  File description printer


let rec print_lignes
  f n entête ep_barre
  col_barre col_liste invisible
  add_limit new_marker_start new_marker_end separator
  ligne =
  let inv_col = col_liste#get#get#col in
    pp_open_vbox f 0;
    pp_print_string f
      ("<tr><td bgcolor=\""^col_liste#get#next#col^"\">");
    pp_print_break f 0 2;
    begin match ligne with
        Href h ->
          pp_open_box f 2;
          if h.href_add >= add_limit then
            pp_print_string f new_marker_start;
          pp_print_string f "<a"; pp_print_space f ();
          pp_print_string f ("href=\""^h.href_url^"\">");
          pp_print_cut f ();
(*        pp_print_string f ("<img href=\""^h.href_icon^"\">");
          pp_print_cut f ();
*)        pp_print_string f h.href_contenu;
          pp_print_cut f ();
          pp_print_string f "</a>";
          if h.href_add >= add_limit then
            pp_print_string f new_marker_end;
          if h.href_description <> "" then begin
            pp_print_string f separator;
            pp_print_cut f ();
            pp_print_string f h.href_description
          end;
          pp_close_box f ();
      | Liste {l_header = h; l_refs = l} ->
          let e = {enom = h.hd_contenu; enum = n#get}::entête
          in pp_open_vbox f 2;
            if h.hd_add >= add_limit then
              pp_print_string f new_marker_start;
            pp_print_string f
              ("<font size=\"+1\"><strong><a href=\""^(name_of_entête e)
               ^"\">"^h.hd_contenu^"</a></strong></font>");
            if h.hd_add >= add_limit then
              pp_print_string f new_marker_end;
            if h.hd_description <> "" then begin
              pp_print_string f separator;
              pp_print_cut f ();
              pp_print_string f h.hd_description
            end;
            pp_print_cut f ();
            print_table f e ep_barre
              col_barre col_liste invisible inv_col
              add_limit new_marker_start new_marker_end separator
              l;
            pp_close_box f ()
      | Separator ->
          pp_print_string f "<hr>";
          pp_print_cut f ()
      | Filtered_out -> failwith "filter"
    end;
    pp_print_break f 0 2;
    pp_print_string f "</td></tr>";
    pp_close_box f ()
and print_table f entête ep_barre
  col_barre col_liste invisible inv_col
  add_limit new_marker_start new_marker_end separator =
  function
      [] -> ()
    | l ->
        pp_open_vbox f 0;
        pp_print_string f ("<table bgcolor=\""^
                           (col_liste#get#get#col)^"\">");
        pp_print_break f 0 2;
        pp_open_vbox f 0;
        pp_print_string f "<tr>";
        pp_print_break f 0 2;
          pp_open_vbox f 0;
          pp_print_string f "<td width=\"";
          pp_print_int f ep_barre;
          pp_print_string f
            ("\" bgcolor=\""^
             (if invisible then inv_col
              else col_barre#get#next#col)^
             "\"><img src=\"1x1.gif\" alt=\"\" height=1 width=1></td>");
          pp_print_cut f ();
          pp_print_string f "<td>";
          pp_print_break f 0 2;
            pp_print_string f "<table>";
            let ccl = col_liste#dup
            and ccb = col_barre#dup in
            ccb#next;
            ccl#next;
            let n = new compteur in
              List.iter (fun li -> pp_print_break f 0 2;
                           print_lignes
                             f n entête ep_barre
                             ccb ccl invisible
                             add_limit new_marker_start new_marker_end
                             separator li) l;
              pp_print_string f "</table>";
          pp_print_break f 0 (-2);
          pp_print_string f "</td>";
          pp_close_box f ();
        pp_print_break f 0 (-2);
        pp_print_string f "</tr>";
        pp_close_box f ();
      pp_print_break f 0 (-2);
      pp_print_string f "</table>";
      pp_close_box f ()

let print_fichier
  répertoire titre meta footer css
  col_fond col_texte col_link col_vlink col_alink
  ep_barre col_barre col_liste invisible
  add_limit new_marker_start new_marker_end separator
  fichier =
  let oc = open_out (Filename.concat
                       répertoire
                       (name_of_entête fichier.tête))
  in let f = make_formatter (output oc) (fun () -> flush oc)
  in pp_open_vbox f 2;
    pp_print_string f "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">"; pp_print_cut f ();
    pp_print_string f "<html>"; pp_print_cut f ();
    pp_open_vbox f 2;
    pp_print_string f "<head>"; pp_print_cut f ();
    List.iter (fun m -> pp_print_string f m; pp_print_cut f ()) meta;
    begin match css with
      | Some url ->
          pp_print_string f ("<link href=\""^url^
                             "\" rel=\"stylesheet\" type=\"text/css\">");
          pp_print_cut f ()
      | None -> ()
    end;
    begin match fichier.tête with
        [] -> pp_print_string f ("<title>"^titre^"</title>")
      | l -> pp_print_string f ("<title>"^titre^": "
                                ^((List.hd l).enom)^"</title>")
    end;
    pp_close_box f (); pp_print_cut f ();
    pp_print_string f "</head>"; pp_print_cut f ();
    pp_open_vbox f 2;
    begin match css with
      | Some _ -> pp_print_string f "<body>"
      | None ->
          pp_print_string f
            ("<body text=\""^col_texte
             ^"\" link=\""^col_link
             ^"\" vlink=\""^col_vlink
             ^"\" alink=\""^col_alink
             ^"\" bgcolor=\""^col_fond^"\">")
    end;
    pp_print_cut f ();
    begin match fichier.tête with
        [] -> pp_print_string f ("<h2>"^titre^"</h2>")
      | l -> pp_print_string f ("<h2>"^titre^": "
                                ^((List.hd l).enom)^"</h2>")
    end;
    pp_print_cut f ();
    print_entête f fichier.tête; pp_print_cut f ();
    pp_open_vbox f 2;
    pp_print_string f "<p>"; pp_print_cut f ();
    print_table f fichier.tête ep_barre col_barre
      col_liste invisible col_fond
      add_limit new_marker_start new_marker_end separator
      fichier.corps;
    print_entête f fichier.tête; pp_print_cut f ();
    pp_print_string f footer;
    pp_close_box f (); pp_print_cut f ();
    pp_print_string f "</body>";
    pp_close_box f (); pp_print_cut f ();
    pp_print_string f "</html>";
    pp_print_flush f ();
    close_out oc

let hierarchie doc ~title ~footer ~dir ~depth
  ~css ~bg:col_fond ~text:col_texte ~link:col_link
  ~vlink:col_vlink ~alink:col_alink
  ~bar_width:ep_barre ~bar:col_barre ~list:col_liste
  ~visibility:invisible ~new_age:max_new_age
  ~new_start:new_marker_start ~new_end:new_marker_end ~separator
  =
  let titre = (match title with
                   None -> doc.titre
                 | Some t -> t)
  and footer = (match footer with
                   None -> doc.footer
                 | Some f -> f)
  and add_limit = (Unix.time ()) -. max_new_age
  in
    Files.iter
      (print_fichier dir titre doc.meta footer css
         col_fond col_texte col_link col_vlink col_alink
         ep_barre col_barre#dup col_liste#dup invisible
         add_limit new_marker_start new_marker_end separator)
      (parcours Files.empty depth [] doc.bmk)
   



Previous Up Next