helm/ocaml/logger/ui_logger.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  ]
  11
  12 type html_msg = [ `Error of html_tag | `Msg of html_tag ]
  13
  14 let string_of_html_msg =
  15   let rec string_of_html_tag = function
  16     | `T s -> s
  17     | `L msgs -> String.concat "\n" (List.map string_of_html_tag msgs)
  18     | `BR -> "\n"
  19   in
  20   function
  21     | `Error tag -> "Error: " ^ string_of_html_tag tag
  22     | `Msg tag -> string_of_html_tag tag
  23
  24 let html_of_html_msg =
  25   let rec string_of_html_tag = function
  26     | `T s -> s
  27     | `L msgs ->
  28         sprintf "<ul>\n%s\n</ul>"
  29           (String.concat "\n"
  30             (List.map
  31               (fun msg -> sprintf "<li>%s</li>" (string_of_html_tag msg))
  32               msgs))
  33     | `BR -> "<br />\n"
  34   in
  35   function
  36     | `Error tag -> "<b>Error: " ^ string_of_html_tag tag ^ "</b>"
  37     | `Msg tag -> string_of_html_tag tag
  38
  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
  42  let tv =
  43    GText.view ~editable:false ~cursor_visible:false
  44     ?width ?height ~packing:(scrolled_window#add) ()
  45  in
  46  let green =
  47   tv#buffer#create_tag
  48    [`FOREGROUND_SET true ;
  49     `FOREGROUND_GDK
  50      (Gdk.Color.alloc (Gdk.Color.get_system_colormap ()) (`NAME "green"))]
  51  in
  52  let red =
  53   tv#buffer#create_tag
  54    [`FOREGROUND_SET true ;
  55     `FOREGROUND_GDK
  56      (Gdk.Color.alloc (Gdk.Color.get_system_colormap ()) (`NAME "red"))]
  57  in
  58  object (self)
  59
  60    method log ?(append_NL = true)
  61     (m : [`Msg of html_tag | `Error of html_tag])
  62    =
  63     let process_msg tags =
  64      let rec aux =
  65       function
  66          `T s -> tv#buffer#insert ~tags s
  67        | `L l -> List.iter aux l
  68        | `BR -> tv#buffer#insert ~tags "\n"
  69      in
  70      aux
  71     in
  72     (match m with
  73      | `Msg m -> process_msg [green] m
  74      | `Error m -> process_msg [red] m);
  75     if append_NL then
  76       process_msg [] `BR;
  77     vadj#set_value (vadj#upper)
  78
  79    val mutable cic_indent_level = 0
  80
  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
  85      let msg =
  86        get_indent () ^
  87        (match cic_msg with
  88        | `Start_type_checking uri ->
  89            incr ();
  90            sprintf "Type checking of %s started" (UriManager.string_of_uri uri)
  91        | `Type_checking_completed uri ->
  92            decr ();
  93            sprintf "Type checking of %s completed"
  94             (UriManager.string_of_uri uri)
  95        | `Trusting uri ->
  96            sprintf "%s is trusted" (UriManager.string_of_uri uri))
  97      in
  98      self#log ~append_NL (`Msg (`T msg))
  99
 100   end
 101