Source file outputs.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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** A window to display various output boxes with tabs. *)

open Stk

class type output =
  object
    method name : string
    method label : string
    method set_label : string -> unit
    method box : Widget.widget
    method on_destroy : unit
  end;;

class outputs ?(on_destroy=fun() -> ()) () =
  object(self)
    inherit Gui_base.outputs ()
    method coerce = self#notebook#coerce

    val mutable pages = ([] : output list)

    method output_by_name name =
      List.find (fun o -> o#name = name) pages

    method private output_pos name =
      let rec iter n = function
        [] -> raise Not_found
      | h :: q -> if h#name = name then n else iter (n+1) q
      in
      iter 0 pages

    method add_output (o : output) =
      try
        ignore(self#output_by_name o#name);
        failwith (Printf.sprintf "Output \"%s\" already present." o#name)
      with
        Not_found ->
          let tab = new Gui_base.outputs_note_tab () in
          tab#wlabel#set_text o#label;
          let (o : output) = object
              method name = o#name
              method label = o#label
              method box = o#box
              method set_label s = o#set_label s; tab#wlabel#set_text s
              method on_destroy = o#on_destroy
            end
          in
          ignore(tab#wb_close#connect Widget.Activated
           (fun () ->
              let n = self#output_pos o#name in
              notebook#remove_page n;
              o#box#destroy;
              pages <- List.filter (fun o2 -> o2#name <> o#name) pages;
              match pages with
                [] -> toplevel#hide
              | _ -> ()
           )
          );
          ignore(notebook#pack ~label:tab#hbox#coerce o#box);
          pages <- pages @ [o]

    method show name =
      toplevel#show;
      let n = self#output_pos name in
      ignore(notebook#set_active_page n)

    initializer
      ignore(toplevel#connect Widget.Destroy
        (fun () -> List.iter (fun o -> o#on_destroy) pages; on_destroy (); true));
      toplevel#show
  end
;;

let outputs_window = ref None;;
let outputs () =
  match !outputs_window with
    None ->
      let o = new outputs
        ~on_destroy: (fun () -> outputs_window := None)
          ()
      in
      outputs_window := Some o; o
  | Some o -> o
;;
(*
let watch_and_insert ?(on_end=fun() -> ()) ic insert =
  let gchan = GMain.Io.channel_of_descr (Unix.descr_of_in_channel ic) in
  let buf_size = 512 in
  let buf = Bytes.make buf_size 'x' in
  let rec f_read l =
    try
      if List.mem `IN l then
        begin
          let n = GMain.Io.read gchan ~buf ~pos: 0 ~len: buf_size in
          (
           (
            try insert (Bytes.sub_string buf 0 n)
            with _ -> ()
           );
           (n < buf_size) || (f_read l)
          )
        end
      else
        if List.mem `HUP l then
          (
           on_end ();
           false
          )
        else
          true
    with
      e -> prerr_endline (Printexc.to_string e); true
  in
  GMain.Io.add_watch
    ~prio: 0
    ~cond: [ `IN ; `HUP ]
    ~callback: f_read gchan
;;

let run_and_read_in_buffer command insert on_end =
  let com = Printf.sprintf "%s 2>&1" command in
  let ic = Unix.open_process_in com in
  let on_end () =
    let ret =
      match Unix.close_process_in ic with
        Unix.WEXITED n
      | Unix.WSIGNALED n
      | Unix.WSTOPPED n -> n
    in
    on_end ret
  in
  ignore(watch_and_insert ~on_end ic insert)
;;
*)


class text_output ?(on_destroy=fun () -> ()) (name : string) =
  let scr = Bin.scrollbox () in
  let tl = Textlog.textlog ~theme:"terminal" ~pack:scr#set_child () in
  let mutex = Lwt_mutex.create () in
  object(self)
    method name = name
    val mutable label = name
    method label = label
    method set_label s = label <- s
    method box = scr#coerce
    method scrollbox = scr

    method reset = ignore(tl#delete ())

    method insert text = tl#raw text

    method run command ?(reset=false) (f_on_end : int -> unit) =
      let com = Lwt_process.shell command in
      let rec read_and_print ic =
        match%lwt Lwt_io.read_line ic with
        | exception End_of_file -> Lwt.return_unit
        | line -> self#insert line ; self#insert "\n" ; read_and_print ic
      in
      if reset then self#reset;
      let%lwt () = Lwt_mutex.lock mutex in
      try%lwt
        Lwt_process.with_process_full com
          (fun p ->
             let%lwt () = Lwt.join
               [read_and_print p#stdout ; read_and_print p#stderr]
             in
             self#insert "" ;
             match%lwt p#close with
             | Unix.WEXITED n
             | Unix.WSTOPPED n
             | Unix.WSIGNALED n ->
                 f_on_end n; Lwt.return_unit;
                 Lwt_mutex.unlock mutex ;
                 Lwt.return_unit
          )
      with e -> Lwt_mutex.unlock mutex; Lwt.fail e

    method contents = tl#text ()

    method on_destroy = on_destroy ()
    method view = tl#as_textview

    initializer
      ()
      (*Gtksv_utils.register_source_view view;
      Gtksv_utils.register_source_buffer view#source_buffer;
      Gtksv_utils.apply_sourceview_props view
        (Gtksv_utils.read_sourceview_props ()) ;*)
   end;;
(*
class interactive_output ?(on_destroy=fun() -> ()) ~name ~command =
  let command = Printf.sprintf "%s 2>&1" command in
  let (ic, oc) = Unix.open_process command in
  let destroyed = ref false in
  let id_watch = ref None in
  let on_destroy () =
    on_destroy ();
    (
     match !id_watch with
       None -> ()
     | Some id -> GMain.Io.remove id
    );
    if not !destroyed then
      (
       ignore(Unix.close_process (ic, oc)) ;
       destroyed := true;
      )
  in
  object(self)
    inherit text_output ~on_destroy name

    method run com ?(reset=false) f =
      (
       match !id_watch with
         Some _ -> ()
       | None ->
           id_watch := Some
             (
              watch_and_insert
                ~on_end: self#view#destroy
                ic self#insert
            )
      );
      if reset then self#reset;
      try output_string oc com; flush oc; f 0
      with _ -> f 1

  end;;
*)