Source file log.ml

(*********************************************************************************)
(*                Chamo                                                          *)
(*                                                                               *)
(*    Copyright (C) 2003-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    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                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(* $Id: cam_log.ml 758 2011-01-13 07:53:27Z zoggy $ *)

open Stk

let log_src = Logs.Src.create Messages.software

let group = ref Ocf.group
let add_to_group path o = group := Ocf.add !group path o; o
let group () = !group

let color s ?(doc=Printf.sprintf "color for %s messages" s) def =
  add_to_group ["colors"; s] (Ocf.string ~doc def)

let color_app = color "app" "white"
let color_error = color "error" "red"
let color_warning = color "warning" "orange"
let color_info = color "info" "green"
let color_debug = color "debug" "yellow"

let font = add_to_group ["font"]
  (Ocf.string ~doc:"font for messages" "fixed 10")

let level_wrapper =
  let to_j ?with_doc k = `String (Logs.level_to_string k) in
  let from_j ?def = function
  | `String s ->
      (match Logs.level_of_string s with
      | Ok l -> l
      | Error (`Msg _) ->
           failwith (Printf.sprintf "invalid log level %S" s)
      )
  | json ->
      let msg = Printf.sprintf
        "Invalid key %S" (Yojson.Safe.to_string json)
      in
      failwith msg
  in
  Ocf.Wrapper.make to_j from_j

let level = add_to_group ["level"]
  (Ocf.option ~doc:"log level"
    ~cb: (fun level -> Logs.Src.set_level log_src level)
    level_wrapper (Some Logs.Info))

let length = add_to_group ["length"]
  (Ocf.int ~doc:"number of characters kept in log" 100_000)

module LevMap =
  Map.Make(struct type t = Logs.level let compare = Stdlib.compare end)

class box () =
  let scr = Scrollbox.scrollbox () in
  (*let () = Gtksv_utils.register_source_buffer buffer in*)
  let textlog = Stk.Textlog.textlog ~pack: scr#set_child () in
  (*
     let () = Gtksv_utils.register_source_view source_view in
     let () = Gtksv_utils.apply_sourceview_props source_view
     (Gtksv_utils.read_sourceview_props ())
     in*)
  object(self)
    method box = scr#coerce
    method textlog = textlog
  end

let log_window () =
  let window = Stk.App.create_window ~show:false
      ~resizable:true
      ~w:500 ~h: 600
      (Messages.software ^ " log")
  in
  ignore (window#connect Window.Close (fun _ -> window#hide; true));
  let vbox = Box.vbox ~pack:window#set_child () in
  let v = new box () in
  vbox#pack v#box ;
  let (wb_close,_) = Button.text_button
      ~text: Messages.close
      ~pack:(vbox#pack ~vexpand:0)
      ()
  in
  let _ = wb_close#connect Widget.Activated
    (fun () -> window#hide)
  in
  object
    method window = window
    method textlog = v#textlog
  end

let the_log_window = ref None

let get_log_window () =
  match !the_log_window with
  | Some w -> w
  | None ->
      let w = log_window () in
      the_log_window := Some w;
      w

let src = Logs.Src.create "chamo"
let app f = Logs.app ~src f
let err f = Logs.err ~src f
let warn f = Logs.warn ~src f
let info f = Logs.info ~src f
let debug f = Logs.debug ~src f

let show_log_window () =
  let w = get_log_window () in
  w#window#show

let hide_log_window () =
  let w = get_log_window () in
  w#window#hide

(*
let lwt_reporter app =
  let buf_fmt ~like =
    let b = Buffer.create 512 in
    Fmt.with_buffer ~like b,
    fun () -> let m = Buffer.contents b in Buffer.reset b; m
  in
  let ppf, b_flush = buf_fmt ~like:Fmt.stdout in
  let reporter = Logs_fmt.reporter ~app:ppf ~dst:ppf () in
  let report src level ~over k msgf =
    let k () =
      let write () =
        let%lwt w = get_log_window app in
        w#print level (b_flush())
      in
      let unblock () = over (); Lwt.return_unit in
      Lwt.finalize write unblock |> Lwt.ignore_result;
      k ()
    in
    reporter.Logs.report src level ~over:(fun () -> ()) k msgf;
  in
  { Logs.report = report }
*)