]> matita.cs.unibo.it Git - helm.git/blob - helm/ocaml/logger/helmLogger.ml
first check-in of cic_notation
[helm.git] / helm / ocaml / logger / helmLogger.ml
1
2 open Printf
3
4 (* HTML simulator (first in its kind) *)
5
6 type html_tag =
7  [ `T of string
8  | `L of html_tag list 
9  | `BR
10  | `DIV of int * string option * html_tag
11  ]
12
13 type html_msg = [ `Error of html_tag | `Msg of html_tag ]
14
15 type logger_fun = ?append_NL:bool -> html_msg -> unit
16
17 let rec string_of_html_tag =
18   let rec aux indent =
19     let indent_str = String.make indent ' ' in
20     function
21     | `T s -> s
22     | `L msgs ->
23         String.concat ("\n" ^ indent_str) (List.map (aux indent) msgs)
24     | `BR -> "\n" ^ indent_str
25     | `DIV (local_indent, _, tag) ->
26         "\n" ^ indent_str ^ aux (indent + local_indent) tag
27   in
28   aux 0
29
30 let string_of_html_msg = function
31   | `Error tag -> "Error: " ^ string_of_html_tag tag
32   | `Msg tag -> string_of_html_tag tag
33
34 let rec html_of_html_tag = function
35   | `T s -> s
36   | `L msgs ->
37       sprintf "<ul>\n%s\n</ul>"
38         (String.concat "\n"
39           (List.map
40             (fun msg -> sprintf "<li>%s</li>" (html_of_html_tag msg))
41             msgs))
42   | `BR -> "<br />\n"
43   | `DIV (indent, color, tag) ->
44       sprintf "<div style=\"%smargin-left:%fcm\">\n%s\n</div>"
45         (match color with None -> "" | Some color -> "color: " ^ color ^ "; ")
46         (float_of_int indent *. 0.5)
47         (html_of_html_tag tag)
48
49 let html_of_html_msg =
50   function
51     | `Error tag -> "<b>Error: " ^ html_of_html_tag tag ^ "</b>"
52     | `Msg tag -> html_of_html_tag tag
53
54 let log_callbacks = ref []
55
56 let register_log_callback logger_fun =
57   log_callbacks := !log_callbacks @ [ logger_fun ]
58
59 let log ?append_NL html_msg =
60   List.iter (fun logger_fun -> logger_fun ?append_NL html_msg) !log_callbacks
61