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 "" (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 class html_logger ?width ?height ?packing ?show () =
  25  let scrolled_window = GBin.scrolled_window ?packing ?show () in
  26  let vadj = scrolled_window#vadjustment in
  27  let tv =
  28    GText.view ~editable:false ~cursor_visible:false
  29     ?width ?height ~packing:(scrolled_window#add) ()
  30  in
  31  let green =
  32   tv#buffer#create_tag
  33    [`FOREGROUND_SET true ;
  34     `FOREGROUND_GDK
  35      (Gdk.Color.alloc (Gdk.Color.get_system_colormap ()) (`NAME "green"))]
  36  in
  37  let red =
  38   tv#buffer#create_tag
  39    [`FOREGROUND_SET true ;
  40     `FOREGROUND_GDK
  41      (Gdk.Color.alloc (Gdk.Color.get_system_colormap ()) (`NAME "red"))]
  42  in
  43  object (self)
  44
  45    method log ?(append_NL = true)
  46     (m : [`Msg of html_tag | `Error of html_tag])
  47    =
  48     let process_msg tags =
  49      let rec aux =
  50       function
  51          `T s -> tv#buffer#insert ~tags s
  52        | `L l -> List.iter aux l
  53        | `BR -> tv#buffer#insert ~tags "\n"
  54      in
  55      aux
  56     in
  57     (match m with
  58      | `Msg m -> process_msg [green] m
  59      | `Error m -> process_msg [red] m);
  60     if append_NL then
  61       process_msg [] `BR;
  62     vadj#set_value (vadj#upper)
  63
  64    val mutable cic_indent_level = 0
  65
  66    method log_cic_msg ?(append_NL = true) (cic_msg: CicLogger.msg) =
  67      let get_indent () = String.make cic_indent_level ' ' in
  68      let incr () = cic_indent_level <- cic_indent_level + 1 in
  69      let decr () = cic_indent_level <- cic_indent_level - 1 in
  70      let msg =
  71        get_indent () ^
  72        (match cic_msg with
  73        | `Start_type_checking uri ->
  74            incr ();
  75            sprintf "Type checking of %s started" (UriManager.string_of_uri uri)
  76        | `Type_checking_completed uri ->
  77            decr ();
  78            sprintf "Type checking of %s completed"
  79             (UriManager.string_of_uri uri)
  80        | `Trusting uri ->
  81            sprintf "%s is trusted" (UriManager.string_of_uri uri))
  82      in
  83      self#log ~append_NL (`Msg (`T msg))
  84
  85   end
  86