Source file textlog.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the               *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public                  *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** A widget to display {!Logs} message.*)

[@@@landmark "auto"]

(** Property ["log_max_size"] so that log will not keep more
  characters than specified. Default is [30_000]. *)
let max_size = Props.int_prop ~default:30000 "log_max_size"
let css_max_size = Theme.int_prop max_size

(** The [textlog] widgets to display log messages.

  This widget inherits from {!Textview.class-textview} and
  provides methods to display log messages.
*)
class textlog ?(classes=[]) ?name ?props ?wdata () =
  let classes = "log" :: classes in
  object(self)
    inherit Textview.textview ~classes ?name ?props ?wdata () as super
    val mutable log_cursor = None

    (** {2 Properties} *)

    method max_size = self#get_p max_size
    method set_max_size = self#set_p max_size
      (** Property {!val-max_size}. *)

    (** {2 Log-printing functions}

      Function for each log level inserts the given message with a
      {{!Texttag.T.t}tag} associated to header characters:
      {!Texttag.tag_debug}, {!Texttag.tag_info}, {!Texttag.tag_warning},
      {!Texttag.tag_error} or {!Texttag.tag_app}.

      The {{!Texttag.Theme.prop}theme} property of the widget will
      use this tag to display the message header with the required text properties.
    *)

    method debug ?src str = self#insert_msg ?src ~tags:[Texttag.tag_debug] str
    method info ?src str = self#insert_msg ?src ~tags:[Texttag.tag_info] str
    method warn ?src str = self#insert_msg ?src ~tags:[Texttag.tag_warning] str
    method error ?src str = self#insert_msg ?src ~tags:[Texttag.tag_error] str
    method app ?src str = self#insert_msg ?src ~tags:[Texttag.tag_app] str

    (** [insert_msg ?src ~tags str] inserts the given message [str].
      Optional argument [src] indicates the {{!Logs.Src.t}log source}.
      If it is provided, then the message is
      preceded by the string ["[source]"] associated to given text tags.
      [source] is the log source name.*)
    method insert_msg ?src ~tags str =
      (match src with
       | None -> super#insert ~tags ?c:log_cursor str ;
       | Some src ->
           super#insert ~tags ?c:log_cursor (Printf.sprintf "[%s]" (Logs.Src.name src));
           super#insert str ?c:log_cursor
      );
      let size = Textbuffer.size buffer in
      let msize = self#max_size in
      if size > msize then
        let _ = self#delete ~start:0 ~size:(size - msize) () in
        ()
      else
        ()

    (** [v#raw str] prints message [str] with no tags and no source.*)
    method raw str = self#insert ~tags:[] str

    method print ?src level =
      match level with
      | Logs.Debug -> self#debug ?src
      | Logs.Info -> self#info ?src
      | Logs.Warning -> self#warn ?src
      | Logs.Error -> self#error ?src
      | Logs.App -> self#app ?src

    initializer
      List.iter self#add_handled_tag Texttag.log_tags;
      let c = self#add_cursor () in
      log_cursor <- Some c
  end


(** Convenient function to create a {!class-textlog}.
  [max_size] can specified a value for {!val-max_size} property.
  [theme] can specify a theme name to use.
  See {!Widget.section-widget_arguments} for other arguments. *)
let textlog ?classes ?name ?props ?wdata ?theme ?maxsize ?pack () =
  let w = new textlog ?classes ?name ?props ?wdata () in
  Option.iter (w#set_p max_size) maxsize ;
  w#set_p Textview.show_cursors false ;
  w#set_p Props.editable false ;
  w#set_p Textview.wrap_mode Textview.Wrap_char ;
  Option.iter w#set_tagtheme theme ;
  Widget.may_pack ?pack w#coerce ;
  w

(** [reporter textlog] creates a {!Logs.reporter} which will
  dispatch log messages according to the presence of
  {!Log.tag} in message tags: if present, the message is a Stk
  log message and will be displayed on stderr, else if will
  be displayed in the [textlog] widget. *)
let reporter (logbox : textlog) =
  let buf_fmt () =
    let b = Buffer.create 512 in
    Format.formatter_of_buffer b,
    fun () -> let m = Buffer.contents b in Buffer.reset b; m
  in
  let ppf, b_flush = buf_fmt () in
  (*let reporter = Logs.format_reporter ~app:ppf ~dst:ppf () in*)
  let write_stk level () =
    let str = b_flush () in
      let str = Printf.sprintf "[%s]%s"
        (Logs.level_to_string (Some level)) str
      in
      Lwt_io.write Lwt_io.stderr str
  in
  let write_other src level () =
    let str = b_flush () in
    (
     try logbox#print ~src level str
     with e -> prerr_endline (Printexc.to_string e)
    );
    (*Lwt.return_unit*)
  in
  let k_ write level ~over k _ =
    let unblock () = over (); Lwt.return_unit in
    Lwt.finalize (write level) unblock |> Lwt.ignore_result;
    k ()
  in
  let print_stk src level ~over k fmt =
    let k = k_ write_stk level ~over k in
    Format.kfprintf k ppf ("[%s] @[" ^^ fmt ^^ "@]@.")
      (Logs.Src.name src)
  in
  let print_other src level ~over k fmt =
    (*let k = k_ (write_other src) level ~over k in*)
    let k _ = write_other src level () ; over () ; k () in
    Format.kfprintf k ppf (fmt ^^ "@.")
  in
  let report src level ~over k msgf =
    msgf @@ fun ?header ?tags fmt ->
      ignore(header);
      match tags with
      | Some set when Logs.Tag.mem Log.tag set -> print_stk src level ~over k fmt
      | _ -> print_other src level ~over k fmt
  in
  { Logs.report = report }