4 (* HTML simulator (first in its kind) *)
12 type html_msg = [ `Error of html_tag | `Msg of html_tag ]
14 let string_of_html_msg =
15 let rec string_of_html_tag = function
17 | `L msgs -> String.concat "\n" (List.map string_of_html_tag msgs)
21 | `Error tag -> "Error: " ^ string_of_html_tag tag
22 | `Msg tag -> string_of_html_tag tag
24 let html_of_html_msg =
25 let rec string_of_html_tag = function
28 sprintf "<ul>\n%s\n</ul>"
31 (fun msg -> sprintf "<li>%s</li>" (string_of_html_tag msg))
36 | `Error tag -> "<b>Error: " ^ string_of_html_tag tag ^ "</b>"
37 | `Msg tag -> string_of_html_tag tag
39 class html_logger ?width ?height ?packing ?show () =
40 let scrolled_window = GBin.scrolled_window ?packing ?show () in
41 let vadj = scrolled_window#vadjustment in
43 GText.view ~editable:false ~cursor_visible:false
44 ?width ?height ~packing:(scrolled_window#add) ()
48 [`FOREGROUND_SET true ;
50 (Gdk.Color.alloc (Gdk.Color.get_system_colormap ()) (`NAME "green"))]
54 [`FOREGROUND_SET true ;
56 (Gdk.Color.alloc (Gdk.Color.get_system_colormap ()) (`NAME "red"))]
60 method log ?(append_NL = true)
61 (m : [`Msg of html_tag | `Error of html_tag])
63 let process_msg tags =
66 `T s -> tv#buffer#insert ~tags s
67 | `L l -> List.iter aux l
68 | `BR -> tv#buffer#insert ~tags "\n"
73 | `Msg m -> process_msg [green] m
74 | `Error m -> process_msg [red] m);
77 vadj#set_value (vadj#upper)
79 val mutable cic_indent_level = 0
81 method log_cic_msg ?(append_NL = true) (cic_msg: CicLogger.msg) =
82 let get_indent () = String.make cic_indent_level ' ' in
83 let incr () = cic_indent_level <- cic_indent_level + 1 in
84 let decr () = cic_indent_level <- cic_indent_level - 1 in
88 | `Start_type_checking uri ->
90 sprintf "Type checking of %s started" (UriManager.string_of_uri uri)
91 | `Type_checking_completed uri ->
93 sprintf "Type checking of %s completed"
94 (UriManager.string_of_uri uri)
96 sprintf "%s is trusted" (UriManager.string_of_uri uri))
98 self#log ~append_NL (`Msg (`T msg))