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

(** Main gui classes *)

module Widget = Stk.Widget
module Menu = Stk.Menu
module Pack = Stk.Pack

(*let window_pixmap =
  Filename.concat Installation.pixmap_dir "chamo.png"

let window_pixbuf =
  try Some (GdkPixbuf.from_file window_pixmap)
  with _ -> None
*)

(* FIXME: no need to reparent view in a hidden window now
let hidden_views_box = ref (None : unit Pack.box option)*)
let hidden_views = ref ([] : View.gui_view list)

let hide_view paned v =
  hidden_views := v :: !hidden_views ;
  paned#unpack v#box

let pop_last_hidden_view () =
  match !hidden_views with
  | [] -> None
  | v :: q ->
      (*match !hidden_views_box with
      | None -> None
      | Some c ->*)
          hidden_views := q;
          (*c#remove v#box#coerce ;*)
          Some v

let pick_hidden_view =
  let rec iter ?view ?kind acc l =
    match l, view, kind with
    | [], _, _ -> (None, List.rev acc)
    | v :: q, Some v2, _ when Oo.id v = Oo.id v2 -> (Some v, (List.rev acc) @ q)
    | v :: q, _, Some k when v#kind = k && v#pickable -> (Some v, (List.rev acc) @ q)
    | v :: q, _, _ -> iter ?view ?kind (v::acc) q
  in
  fun ?view ?kind () ->
    let (r, l) = iter ?view ?kind [] !hidden_views in
    hidden_views := l;
    match r with
    | None -> None
    | Some v ->
        (*match !hidden_views_box with
        | None -> None
        | Some c ->
            c#remove v#box#coerce ;*)
            Some v

let init_view topwin (v : View.gui_view) =
  v#set_on_focus_in
    (fun _ ->
       Log.debug (fun m -> m "on_focus_in(view %S)" v#label);
       topwin#set_active_view (Some v))

let insert_in_pos ele p =
  let rec iter n = function
      [] -> [ele]
    | h :: q ->
        if n = p
        then ele :: h :: q
        else h :: (iter (n+1) q)
  in
  iter 0

let label_of_contents = function
    `View o -> o#label
  | `Paned o -> o#label
  | `Notebook o -> o#label

let id_of_contents = function
    `View o -> Oo.id o
  | `Paned o -> Oo.id o
  | `Notebook o -> Oo.id o

let widget_of_contents = function
    `View gv -> gv#box
  | `Notebook gn -> gn#notebook#coerce
  | `Paned gp -> gp#paned#coerce

let contents_grab_focus = function
    `View gv -> gv#grab_focus
  | `Notebook gn -> gn#grab_focus
  | `Paned gp -> gp#grab_focus

let rec find_container c = function
    `View gv -> None
  | `Paned gp ->
      begin
        let pred c2 = id_of_contents c2 = id_of_contents c in
        let search_child = function
            None -> None
          | Some c2 ->
              if pred c2 then
                Some (`Paned gp)
              else
                find_container c c2
        in
        match search_child gp#child1 with
        | None -> search_child gp#child2
        | Some x -> Some x
      end
  | `Notebook gn ->
        let pred c2 = id_of_contents c2 = id_of_contents c in
        let rec iter = function
            [] -> None
          | (_,c2) :: q ->
              if pred c2 then
                Some (`Notebook gn)
              else
                match find_container c c2 with
                  None -> iter q
                | Some x -> Some x
        in
        iter gn#tabs

class gui_window ?x ?y ?w ?h () =
  let minibuffer = new Minibuffer.minibuffer () in
  object(self)
    inherit Gui_base.main ?x ?y ?w ?h ()
    method x = fst (toplevel#position)
    method y = snd (toplevel#position)
    method width = toplevel#geometry.w
    method height = toplevel#geometry.h

    val mutable key_bindings_trees = []

    val mutable contents :
        [
          `Paned of gui_paned
        | `Notebook of gui_notebook
        | `View of View.gui_view
        ] option = None

    method window = toplevel
    method contents = contents
    method minibuffer = minibuffer

    val mutable active_view : View.gui_view option = None
    method set_active_view gvopt =
      active_view <- gvopt;
      key_bindings_trees <- Commands.trees_for_window
          (match gvopt with None -> [] | Some v -> v#key_bindings);
      self#set_view_interface gvopt;
      minibuffer#set_active false
(*      prerr_endline "active view set!";*)

    method set_view_interface gvopt =
      item_edit#remove_menu ;
      let menu = Menu.menu ~pack:item_edit#set_menu () in
      let l =
        match gvopt with
          None -> [false; false; false]
        | Some gv -> [gv#save <> None; gv#save_as <> None; gv#reload <> None]
      in
      List.iter2 (fun mi b -> mi#set_sensitive b)
        [item_save;item_save_as;item_reload] l;
      let l =
        match gvopt with
          None -> [None;None;None]
        | Some gv -> [gv#paste;gv#copy;gv#cut]
      in
      List.iter2
        (fun text fopt ->
          let (mi,_) = Menu.label_menuitem ~pack:menu#add_item ~text () in
          match fopt with
            None -> mi#set_sensitive false
          | Some f -> ignore(mi#connect Widget.Activated f)
        )
        ["Paste";"Copy";"Cut"]
        l;
      let mb = view_menubar in
      List.iter mb#unpack mb#children_widgets;
      let f (text,entries) =
        let (mi,_) = Menu.label_menuitem ~text ~pack:mb#add_item () in
        let mn = Menu.menu ~pack:mi#set_menu () in
        Menu.fill_menu mn entries
      in
      match gvopt with
        None -> ()
      | Some gv -> List.iter f (List.rev gv#menus)

    method update_menus =
      self#set_view_interface self#active_view

    method active_view = active_view

    method contains_view (v : View.gui_view) =
      match contents with
        None -> false
      | Some (`View v2) -> Oo.id v = Oo.id v2
      | Some c -> find_container (`View v) c <> None

    method get_active_view_container =
      match active_view with
        None -> None
      | Some gv ->
          match contents with
            None -> None
          | Some (`View v) ->
              if Oo.id v = Oo.id gv then
                Some (`Window (self :> gui_window))
              else
                None
          | Some (`Paned gp) ->
              gp#find_view_container gv
          | Some (`Notebook gn) ->
              gn#find_view_container gv

    method destroy_active_view =
      match active_view with
        None -> ()
      | Some v -> v#destroy

    method on_about () =
      Commands.async_command "about"

    method on_new_window () =
      Commands.async_command "new_window"

    method on_open_file () =
      Commands.async_command "open_file"

    method on_destroy_active_view () =
      Commands.async_command "destroy_active_view"

    method reload_active_view =
      match active_view with
        None -> Lwt.return_unit
      | Some gv ->
          match gv#reload with
            None -> Lwt.return_unit
          | Some f -> f ()

    method ask_open_file =
      let dir =
        match active_view with
          None -> Sys.getcwd ()
        | Some v -> Filename.dirname v#filename
      in
      Lwt.async (fun () ->
         Misc.select_file minibuffer
           ~title: "Open file" (Misc.filename_to_utf8 (dir^"/"))
           (fun s -> Commands.eval_command (Printf.sprintf "open_file %s" (Filename.quote s)))
      )

    method widget_opt_of_contents_opt = function
        None -> None
      | Some x -> Some (widget_of_contents x)

    method set_contents =
      begin
        match self#widget_opt_of_contents_opt contents with
          None -> ()
        | Some widget -> vbox#unpack widget
      end;
      fun c ->
        contents <- c;
        match self#widget_opt_of_contents_opt c with
          None -> ()
        | Some widget ->
            begin
              match c with
              | None -> ()
              | Some (`View v) ->
                  v#set_on_destroy self#on_view_destroy;
                  v#set_on_label_change self#set_title
              | Some (`Notebook gn) ->
                  gn#set_on_destroy (fun c -> self#set_contents c);
                  gn#set_on_label_change self#set_title
              | Some (`Paned gp) ->
                  gp#set_on_destroy (fun c -> self#set_contents c);
                  gp#set_on_label_change self#set_title
            end;
            vbox#pack widget;
            vbox#reorder_child widget 1;
            let label =
              match c with
                None -> ""
              | Some c -> contents_grab_focus c; label_of_contents c
            in
            self#set_title label

    method add_view v =
      match contents with
        None ->
          init_view (self :> View.topwin) v;
          self#set_contents (Some (`View v));
      | Some ((`View _) as current_c)
      | Some ((`Paned _) as current_c) ->
          (** TODO: whether a paned or notebook is created should
             be a choice in preferences *)
          let gn = new gui_notebook (self :> View.topwin) () in
          self#set_contents (Some (`Notebook gn));
          gn#add_tab None current_c;
          gn#add_view v
      | Some (`Notebook gn) ->
          gn#add_view v

    method private on_view_destroy () =
      match self#widget_opt_of_contents_opt contents with
        None -> ()
      | Some w ->
          contents <- None;
          vbox#unpack w

    method add_view_in_active_view_container ?(replace=false) v =
      match self#get_active_view_container with
        None -> self#add_view v
      | Some (`Window _) -> self#add_view v
      | Some (`Paned gp) -> gp#add_view ~replace v
      | Some (`Notebook gn) -> gn#add_view v

    method pop_last_hidden_view =
      match pop_last_hidden_view () with
      | None -> ()
      | Some v ->
          self#add_view_in_active_view_container ~replace:true v

    method popup_pick_hidden_view =
      match !hidden_views with
      | [] -> Misc.set_active_action_message "No hidden view"
      | l ->
        let entries = List.map
          (fun view ->
               `I (Misc.escape_menu_label (Printf.sprintf "%s [%s]" view#label view#kind),
                fun () ->
                  match pick_hidden_view ~view () with
                  | None -> ()
                  | Some v -> self#add_view_in_active_view_container ~replace:true v))
              l
          in
          Stk.Menu.popup_menu_entries entries

    method open_file ?attributes f =
      try
        let factory = View.factory_of_filename f in
        match View.factory_open_file ~factory
          (self :> View.topwin) active_view ?attributes f
        with
          `Use_view v -> v#grab_focus
        | `New_view v ->
            init_view (self :> View.topwin) v;
            self#add_view_in_active_view_container ~replace:true v
      with
        Failure s ->
          self#error_message s

    method set_title s =
      let s = if s = "" then "" else ": "^s in
      toplevel#set_title (Printf.sprintf "%s%s" (Misc.to_utf8 Messages.software) s)

    method new_tab =
      match self#get_active_view_container with
      | None -> ()
      | Some (`Window _) ->
          (* it's me ! *)
          (
           match contents with
             Some (`View v) ->
               (
                match v#dup (self :> View.topwin) with
                  None -> ()
                | Some v ->
                    init_view (self :> View.topwin) v;
                    self#add_view v
               )
           | _ -> prerr_endline "Should not be here"
          )
      | Some (`Paned gp) ->
          (
           match active_view with
             None -> ()
           | Some v ->
               match v#dup (self :> View.topwin) with
                 None -> ()
               | Some v ->
                   init_view (self :> View.topwin) v;
                   gp#new_tab (`View v);
                   v#grab_focus;
          )
      | Some (`Notebook gn) ->
          (
           match active_view with
             None -> ()
           | Some v ->
               match v#dup (self :> View.topwin) with
                 None -> ()
               | Some v ->
                   init_view (self :> View.topwin) v;
                   gn#add_view v
          )

    method split_active_view (orientation : Stk.Props.orientation) =
      match self#get_active_view_container with
        None
      | Some (`Window _) ->
          begin
            match contents with
              Some (`View v1) ->
                (
                 match v1#dup (self :> View.topwin) with
                   None -> ()
                 | Some v2 ->
                     let size =
                       let g = v1#box#geometry in
                       g.w, g.h
                     in
                     let gp = new gui_paned (self :> View.topwin) orientation () in
                     self#set_contents (Some (`Paned gp));
                     init_view (self :> View.topwin) v2;
                     gp#set_children_views ~size v1 v2;
                     v2#grab_focus;
                )
            | _ -> ()
          end
      | Some (`Paned gp) -> gp#split_active_view orientation
      | Some (`Notebook gn) -> gn#split_active_view orientation

    method on_new_tab () = Commands.async_command "new_tab"

    method on_split_active_view o () =
      Commands.async_command
        (Printf.sprintf "split_%s"
           (match o with
             `HORIZONTAL -> "horizontally"
           | `VERTICAL -> "vertically"))

    method on_store_layout () = Commands.async_command "store_layout"

    method cycle_tab forward =
      match active_view with
        None -> ()
      | Some v ->
          match contents with
            None -> ()
          | Some mycontents ->
              let rec iter c =
                match find_container c mycontents with
                  None -> None
                | Some (`Notebook gn) ->
                    Some gn
                | Some x -> iter x
              in
              match iter (`View v) with
                None -> ()
              | Some gn -> gn#cycle_tab forward

    method cycle_view =
      match active_view with
        None -> ()
      | Some v ->
          match contents with
            None -> ()
          | Some mycontents ->
              let rec iter c =
                match find_container c mycontents with
                  None ->
                    begin
                      match c with
                        `Paned gp ->
                          begin
                            match gp#child1, gp#child2 with
                              Some c, _
                            | None, Some c -> contents_grab_focus c
                            | None, None -> ()
                          end
                      | `View v ->
                          (* shold not happen *)
                          v#grab_focus
                      | `Notebook nb ->
                          (* give focus to first view in the current tab *)
                          nb#grab_focus
                    end
                | Some ((`Paned gp) as x) ->
                    begin
                      match gp#child1, gp#child2 with
                      | Some c1, Some c2 when id_of_contents c1 = id_of_contents c ->
                          contents_grab_focus c2
                      | _ -> iter x
                    end
                | Some x -> iter x
              in
              iter (`View v)

    method on_close () = Commands.async_command "close_active_window"
    method close = self#window#destroy

    method set_state_message = wl_keystate#set_text

    method set_action_message msg =
      if minibuffer#active then
        ()
      else
        minibuffer#set_text msg

    method error_message s =
      Misc.error_message (Misc.to_utf8 s)

    method save_active_view =
      match active_view with
        None -> Lwt.return_unit
      | Some v ->
          match v#save with
            None -> Lwt.return_unit
          | Some f -> f ()

    method save_active_view_as =
      match active_view with
        None -> Lwt.return_unit
      | Some v ->
          match v#save_as with
            None -> Lwt.return_unit
          | Some f -> f ()

    method display_keyhit_state ~after_handler st =
      let s = Stk.Wkey.string_of_keyhit_state st in
      self#set_state_message s ;
      if not after_handler then
        self#set_action_message ""

    method print_key_bindings =
      let l = Ocf.get Gui_rc.window_key_bindings @
        (match active_view with
          None -> []
        | Some v -> v#key_bindings)
      in
      List.iter
        (fun (st,com) ->
           Log.app (fun m -> m "%s -> %s"
              (Stk.Key.string_of_keystate_list st) com))
        l

    method on_minibuffer_active_change active =
      if active then
        begin
          Stk.Wkey.reset_state toplevel#coerce;
          self#display_keyhit_state ~after_handler: true [];
          key_bindings_trees <- Commands.trees_for_window minibuffer#key_bindings
        end
      else
        match active_view with
          None -> () | Some v -> v#grab_focus

    method paste =
      match active_view with
        None -> ()
      | Some v ->
          match v#paste with
            None -> ()
          | Some f -> f ()
    method copy =
      match active_view with
        None -> ()
      | Some v ->
          match v#copy with
            None -> ()
          | Some f -> f ()
    method cut =
      match active_view with
        None -> ()
      | Some v ->
          match v#cut with
            None -> ()
          | Some f -> f ()

    initializer
      (*FIXME: when available toplevel#set_icon window_pixbuf;*)
      hbox_state#pack minibuffer#box;
      minibuffer#set_on_active_change self#on_minibuffer_active_change;
      ignore(item_close#connect Widget.Activated self#on_close);
      ignore(item_log_window#connect Widget.Activated
       (fun () -> Commands.async_command "log_window"));
      ignore(item_save#connect Widget.Activated
       (fun () -> Commands.async_command "save_active_view"));
      ignore(item_save_as#connect Widget.Activated
       (fun () -> Commands.async_command "save_active_view_as"));
      ignore(item_reload#connect Widget.Activated
       (fun () -> Commands.async_command "reload_active_view"));
      ignore(item_about#connect Widget.Activated
       self#on_about);
      ignore(item_new_window#connect Widget.Activated
       self#on_new_window);
      ignore(item_open#connect Widget.Activated
       self#on_open_file);
      ignore(item_new_tab#connect Widget.Activated
       self#on_new_tab);
      ignore(item_split_horizontally#connect Widget.Activated
       (self#on_split_active_view `HORIZONTAL));
      ignore(item_split_vertically#connect Widget.Activated
       (self#on_split_active_view `VERTICAL));
      ignore(item_destroy#connect Widget.Activated
       self#on_destroy_active_view);
      ignore(item_store_layout#connect Widget.Activated
       self#on_store_layout);
      ignore(item_cycle_tab#connect Widget.Activated
       (fun () -> Commands.async_command "cycle_tab"));
      ignore(item_cycle_view#connect Widget.Activated
       (fun () -> Commands.async_command "cycle_view"));
      (*FIXME: when configwin is ported to stk
      ignore(item_prefs#connect Widget.Activated
       Prefs.edit_preferences) ;*)
      key_bindings_trees <- Commands.trees_for_window [];
      Stk.Wkey.set_handler_trees
        ~stop: (Ocf.get Gui_rc.abort_binding)
        (fun () ->
           Log.debug (fun m ->
             m "%a" Stk.Wkey.pp_handler_trees key_bindings_trees);
           key_bindings_trees)
        ~display_state: self#display_keyhit_state
        evbox#coerce;

  end

and gui_paned (topwin : View.topwin) orientation () =
  let paned = Pack.paned orientation () in
  object(self)
    inherit View.dyn_label

    method paned = paned
    method orientation = orientation
    method position =
      let g = paned#geometry in
      match paned#handle_positions with
      | [] | None :: _ -> g.w
      | (Some (`Percent p)) :: _ ->
          let base = match paned#orientation with Horizontal -> g.w | Vertical -> g.h in
          truncate ((float base *. p) /. 100.)
      | (Some (`Absolute p)) :: _ -> p

    method set_position p =
      let g = paned#geometry in
      paned#set_handle_positions [Some (`Absolute (min p g.w))]

    val mutable child1 :
        [
          `Paned of gui_paned
        | `Notebook of gui_notebook
        | `View of View.gui_view
        ] option = None
    val mutable child2 :
        [
          `Paned of gui_paned
        | `Notebook of gui_notebook
        | `View of View.gui_view
        ] option = None

    method child1 = child1
    method child2 = child2

    val mutable on_destroy =
      (fun (c :  [ `Paned of gui_paned
                | `Notebook of gui_notebook
                | `View of View.gui_view
                ] option) -> ())
    method on_child_view_destroy n =
      List.iter paned#unpack paned#children_widgets;
      on_destroy (if n = 1 then child2 else child1);
      child1 <- None;
      child2 <- None;
      paned#destroy

    method set_on_destroy f = on_destroy <- f

    method on_child_destroy n c =
      if (n <> 1 && n <> 2) then
        Log.err (fun m -> m "Gui.paned#on_child_destroy invalid n = %d" n);
      match (if n = 1 then child1 else child2) with
        None -> () (* strange *)
      | Some c_old ->
          match c with
            None -> (* strange, nothing to replace the child,
                       we do as if it was a view so that the other child
                       replaces the paned in the parent *)
              self#on_child_view_destroy n
          | Some c ->
              let w = widget_of_contents c_old in
              paned#unpack w;
              (if n = 1 then paned#pack ~pos:0 else paned#pack ~pos:1) (widget_of_contents c);
              if n = 1 then child1 <- Some c else child2 <- Some c;
              self#on_child_label_change;
              contents_grab_focus c

    method on_child_label_change =
      let s =
        match child1, child2 with
          None, Some c
        | Some c, None -> label_of_contents c
        | None, None -> " "
        | Some c1, Some c2 -> Printf.sprintf "%s | %s"
              (label_of_contents c1) (label_of_contents c2)
      in
      self#set_label s

    method set_one_child n c =
      begin
        match (if n = 1 then child1 else child2) with
          None -> ()
        | Some c ->
            paned#unpack (widget_of_contents c)
      end;
      if n = 1 then child1 <- Some c else child2 <- Some c;
      begin
        match c with
          `View v ->
            v#set_on_destroy (fun () -> self#on_child_view_destroy n);
            v#set_on_label_change (fun _ -> self#on_child_label_change);
        | `Paned gp ->
            gp#set_on_destroy (self#on_child_destroy n);
            gp#set_on_label_change (fun _ -> self#on_child_label_change);
        | `Notebook gn ->
            gn#set_on_destroy (self#on_child_destroy n);
            gn#set_on_label_change (fun _ -> self#on_child_label_change);
      end;
      (if n = 1 then paned#pack ~pos:0 else paned#pack ~pos:1) (widget_of_contents c);
      self#on_child_label_change;
      contents_grab_focus c

    method set_children_views ~size v1 v2 =
      self#set_one_child 1 (`View v1);
      self#set_one_child 2 (`View v2);
      let g = paned#geometry in
      let p = match orientation with
      | Stk.Props.Vertical -> g.h
      | Horizontal -> g.w
      in
      self#set_position (p / 2)

    method find_view_container :
      View.gui_view -> [ `Notebook of gui_notebook
      | `Paned of gui_paned
      | `Window of gui_window ] option = fun gv ->
      let find_in_child = function
          None -> None
        | Some (`Notebook (gn:gui_notebook)) ->
            gn#find_view_container gv
        | Some (`Paned (gp:gui_paned)) ->
            gp#find_view_container gv
        | Some (`View v) ->
            if Oo.id v = Oo.id gv then
              Some (`Paned (self :> gui_paned))
            else
              None
      in
      match find_in_child child1 with
        None -> find_in_child child2
      | Some x -> Some x

    method new_tab c =
      (* we insert the tab in a view; if we don't have a
         the active view, then we should not be here since
         the new_tab is inserted in the active view container *)
      match topwin#active_view with
        None -> ()
      | Some v ->
          let res =
            match child1 with
              Some (`View v1) when Oo.id v1 = Oo.id v -> Some (1, v1)
            | _ ->
                match child2 with
                  Some (`View v2) when Oo.id v2 = Oo.id v -> Some (2, v2)
                | _ -> None
          in
          match res with
            None -> prerr_endline "Can't insert tab here, we should not be here in this paned"
          | Some (n, cur_view) ->
              paned#unpack cur_view#box;
              let gn = new gui_notebook topwin () in
              (if n = 1 then paned#pack ~pos:0 else paned#pack ~pos:1) gn#notebook#coerce;
              gn#set_on_destroy (self#on_child_destroy n);
              gn#set_on_label_change (fun _ -> self#on_child_label_change);
              if n = 1 then
                child1  <- Some (`Notebook gn)
              else
                child2  <- Some (`Notebook gn);
              gn#add_tab None (`View cur_view);
              gn#add_tab None c;

    method add_view ~replace (v : View.gui_view) =
       match topwin#active_view with
        None -> ()
      | Some av ->
          let res =
            match child1 with
              Some (`View v1) when Oo.id v1 = Oo.id av -> Some (1, v1)
            | _ ->
                match child2 with
                  Some (`View v2) when Oo.id v2 = Oo.id av -> Some (2, v2)
                | _ -> None
          in
          match res with
            None -> prerr_endline "Can't insert view here, we should not be here in this paned"
          | Some (n, cur_view) ->
              if replace then
                (
                 hide_view paned cur_view ;
                 (if n = 1 then paned#pack ~pos:0 else paned#pack ~pos:1) v#box#coerce ;
                 if n = 1 then
                   child1  <- Some (`View v)
                 else
                   child2  <- Some (`View v)
                )
              else
                (
                 let size = let g = paned#geometry in g.w, g.h in
                 paned#unpack cur_view#box;
                 (* TODO: use a user preference to use a tab or a paned *)
                 let gp = new gui_paned topwin orientation () in
                 (if n = 1 then paned#pack ~pos:0 else paned#pack ~pos:2) gp#paned#coerce;
                 gp#set_on_destroy (self#on_child_destroy n);
                 gp#set_on_label_change (fun _ -> self#on_child_label_change);
                 if n = 1 then
                   child1  <- Some (`Paned gp)
                 else
                   child2  <- Some (`Paned gp);
                 gp#set_children_views ~size cur_view v;
                );
              v#grab_focus


    method split_active_view orientation =
      match topwin#active_view with
        None -> ()
      | Some v ->
          let res =
            match child1 with
              Some (`View v1) when Oo.id v1 = Oo.id v -> Some (1, v1)
            | _ ->
                match child2 with
                  Some (`View v2) when Oo.id v2 = Oo.id v -> Some (2, v2)
                | _ -> None
          in
          match res with
            None -> prerr_endline "can't split this, not a view"
          | Some (n, cur_view) ->
              match cur_view#dup topwin with
                None -> ()
              | Some view_copy ->
                  let gp = new gui_paned topwin orientation () in
                  let size = let g = paned#geometry in g.w, g.h in
                  paned#unpack cur_view#box;
                  if n = 1 then
                    child1  <- Some (`Paned gp)
                  else
                    child2  <- Some (`Paned gp);
                  (if n = 1 then paned#pack ~pos:0 else paned#pack ~pos:1) gp#paned#coerce;
                  gp#set_on_label_change (fun _ -> self#on_child_label_change);
                  gp#set_on_destroy (self#on_child_destroy n);
                  init_view topwin view_copy;
                  gp#set_children_views ~size cur_view view_copy;
                  view_copy#grab_focus

    method grab_focus =
      match child1 with
        Some c -> contents_grab_focus c
      | None ->
          match child2 with
            Some c -> contents_grab_focus c
          | None -> ()

  end

and gui_notebook (topwin : View.topwin) () =
  let nb = Stk.Notebook.hnotebook
(* FIXME: properties not in Stk:
      ~border_width: 0
      ~show_border: false
      ~scrollable: true
      *) ()
  in
  object(self)
    inherit View.dyn_label
    method notebook = nb

    val mutable tabs :
        (Stk.Text.label *
           [
             `Paned of gui_paned
           | `Notebook of gui_notebook
           | `View of View.gui_view
           ]
        ) list = []

    method tabs = tabs

    val mutable on_destroy =
      (fun (c :  [ `Paned of gui_paned
                | `Notebook of gui_notebook
                | `View of View.gui_view
                ] option) -> ())
    method destroy =
      match tabs with
        (_,c) :: _ ->
          for i = 0 to List.length tabs - 1 do
            nb#remove_page i
          done;
          on_destroy (Some c);
          nb#destroy
      | [] -> on_destroy None; nb#destroy

    method set_on_destroy f = on_destroy <- f

    method on_tab_destroy c new_c =
      match self#tab_of_contents c with
        None -> Log.warn (fun m -> m "no tab with contents %s (tab contents: %s)"
             (label_of_contents c)
             (String.concat ", " (List.map (fun (_,c) -> label_of_contents c) tabs)))
      | Some n ->
          tabs <- List.filter
              (fun (_,c2) -> id_of_contents c2 <> id_of_contents c) tabs;
          nb#remove_page n;
          match new_c, tabs with
            None, []
          | None, [_] -> self#destroy
          | None, _ -> ()
          | Some new_c, [] ->
              on_destroy (Some new_c);
              nb#destroy
          | Some new_c, _ ->
              self#add_tab (Some n) new_c

    method on_view_destroy v () = self#on_tab_destroy (`View v) None

    method find_view_container :
       View.gui_view -> [ `Notebook of gui_notebook
                        | `Paned of gui_paned
                        | `Window of gui_window ] option =
         fun gv ->
           let find_in_child = function
             | `Notebook (gn:gui_notebook) ->
                 gn#find_view_container gv
             | `Paned (gp:gui_paned) ->
                 gp#find_view_container gv
             | `View v ->
                 if Oo.id v = Oo.id gv then
                   Some (`Notebook (self :> gui_notebook))
                 else
                   None
           in
           let rec iter = function
               [] -> None
             | (_,h) :: q ->
                 match find_in_child h with
                   None -> iter q
                 | Some x -> Some x
           in
           iter self#tabs

    method tab_of_contents c =
      let oid = id_of_contents c in
      let pred c2 = id_of_contents c2 = oid in
      let rec iter n = function
          [] -> None
        | (_,h) :: q ->
            if pred h then Some n else iter (n+1) q
      in
      iter 0 tabs

    method add_view v =
      self#add_tab None (`View v);
      v#grab_focus

    method set_tab_label c s =
      match self#tab_of_contents c with
        None -> ()
      | Some n ->
          let (w,_) = List.nth tabs n in
          w#set_text (Misc.to_utf8 (label_of_contents c));
          self#set_label s

    method add_tab pos c =
      let label = label_of_contents c in
      let wlabel = Stk.Text.label ~text:label () in
      tabs <-
        (match pos with
          None -> tabs @ [wlabel,c]
        | Some pos -> insert_in_pos (wlabel,c) pos tabs
        );
      let w = match c with
        `View gv ->
          gv#set_on_label_change (self#set_tab_label c);
          gv#set_on_destroy (self#on_view_destroy gv);
          gv#box
      | `Notebook gn ->
          gn#set_on_label_change (self#set_tab_label c);
          gn#set_on_destroy (self#on_tab_destroy c);
          gn#notebook#coerce
      | `Paned gp ->
          gp#set_on_label_change (self#set_tab_label c);
          gp#set_on_destroy (self#on_tab_destroy c);
          gp#paned#coerce
      in
      let n =
        match pos with
          None ->
            ignore(nb#pack ~label: wlabel#coerce w);
            List.length tabs - 1
        | Some pos ->
            ignore(nb#pack ~pos ~label: wlabel#coerce w);
            pos
      in
      self#goto_page n;
      contents_grab_focus c

    method split_active_view orientation =
      match topwin#active_view with
        None -> ()
      | Some v1 ->
          match self#tab_of_contents (`View v1) with
            None -> ()
          | Some n ->
              let (wl,_) = List.nth tabs n in
              match v1#dup topwin with
                None -> ()
              | Some v2 ->
                  let size = let g = v1#box#geometry in g.w, g.h in
                  let gp = new gui_paned topwin orientation () in
                  gp#set_on_label_change (self#set_tab_label (`Paned gp));
                  gp#set_on_destroy (self#on_tab_destroy (`Paned gp));
                  init_view topwin v2;
                  gp#set_children_views ~size v1 v2;
                  (*page is removed when v1 is packed in gp nb#remove_page n;*)
                  let rec iter m = function
                      [] -> []
                    | (wl,`View v') :: q when n = m ->
                        (wl, `Paned gp) :: q
                    | h :: q ->
                        h :: (iter (m+1) q)
                  in
                  tabs <- iter 0 tabs;
                  ignore(nb#pack ~label: wl#coerce ~pos:n gp#paned#coerce);
                  self#goto_page n;
                  v2#grab_focus;

    method grab_focus =
      try
        match nb#active_page with
        | None -> ()
        | Some i ->
            let (_,c) = List.nth tabs i in
            contents_grab_focus c
      with _ -> ()

    method cycle_tab forward =
      match nb#active_page with
      | None -> ()
      | Some i ->
          let new_page =
            ((if forward then (+) else (-)) i 1) mod (List.length tabs)
          in
          self#goto_page new_page

    method goto_page n = ignore(nb#set_active_page n)

    method on_switch_page ~prev ~now =
      self#set_label (label_of_contents (snd (List.nth tabs now)))

    initializer
      ignore (nb#connect (Stk.Object.Prop_changed Stk.Notebook.active_page)
       self#on_switch_page);
  end

type gui_windows = gui_window list

let gui_windows : gui_windows ref = ref []

let active_window = ref (None : gui_window option)

let on_last_window_close = ref (fun () -> ())

let on_window_destroy w () =
  gui_windows :=
    List.filter (fun w2 -> Oo.id w <> Oo.id w2) !gui_windows;
  match !gui_windows with
    [] -> !on_last_window_close (); false
  | _ -> false

let create_window ?x ?y ?w ?h () =
  let o = new gui_window ?x ?y ?w ?h () in
  gui_windows := o :: !gui_windows;
  let w = o#window in
  ignore(w#connect Widget.Destroy (on_window_destroy o));
  ignore(w#connect (Stk.Object.Prop_changed Stk.Props.has_focus)
   (fun ~prev ~now -> if now then active_window := Some o));
  w#show;
  o

let _ = Commands.register (Commands.unit_com "new_window"
   (fun () -> ignore(create_window ())))

let in_new_window args =
  let com = Commands.argv_to_string args in
  let w = create_window () in
  active_window := Some w;
  Commands.async_command com

let _ =
  let com = Commands.create_com "in_new_window"
      ~more: "command and arguments to launch with the new window active"
      [| |]
      (fun args -> in_new_window args; Lwt.return_unit)
  in
  Commands.register com

(* FIXME: add about_dialog to Stk
let about_dialog = ref (fun () -> raise Not_found)
let show_about_dialog () =
  try !about_dialog ()
  with Not_found ->
      let dialog = GWindow.about_dialog
        ~authors:
          [(Printf.sprintf "%s <%s>"
             Messages.software_author
               Messages.software_author_mail)]
          ~name: Messages.software
          ~version: Installation.version
          ~website: "https://zoggy.frama.io/chamo"
          ~website_label: "The Chamo website"
          ~position: `CENTER
          ~copyright: Messages.software_copyright
          ~logo: (GdkPixbuf.from_file window_pixmap)
          ~modal: true
          ()
      in
      about_dialog := dialog#present ;
      ignore(dialog#connect#response (fun _ -> dialog#misc#hide()));
      dialog#show ()
;;

let _ = Commands.register (Commands.unit_com "about" show_about_dialog)
*)

let on_active_window f () =
  match !active_window with
    None -> Log.warn (fun m -> m "no active window.")
  | Some o -> f o

let on_active_window_lwt f () =
  match !active_window with
    None -> Log.warn (fun m -> m "no active window."); Lwt.return_unit
  | Some o -> f o

let on_active_window_args (f : gui_window -> string array -> unit) args =
  match !active_window with
  | None ->  Log.warn (fun m -> m "no active window.") ; Lwt.return_unit
  | Some o -> f o args; Lwt.return_unit

let _ =
  let f args =
    let len = Array.length args in
    let () =
      if len <= 0 then
        let g w = w#ask_open_file in
        on_active_window g ()
      else
        let filename = args.(0) in
        let loc = if len = 1 then None else Some args.(1) in
        let attributes =
          match loc with
            None -> None
          | Some loc -> Some ["location", loc]
        in
        let g w = w#open_file ?attributes filename in
        on_active_window g ()
    in
    Lwt.return_unit
  in
  let com =
    { Commands.com_name = "open_file" ;
      Commands.com_args = [| "file" |] ;
      Commands.com_more_args = Some "optional location" ;
      Commands.com_f = f;
    }
  in
  Commands.register com
;;
let open_file_with_encoding args =
  let len = Array.length args in
  if len < 1 then
     let g w =
      let dir =
        match w#active_view with
          None -> Sys.getcwd ()
        | Some v -> Filename.dirname v#filename
      in
      Misc.select_file w#minibuffer
        ~title: "Open file with encoding" (Misc.filename_to_utf8 (dir^"/"))
        (fun s -> Commands.launch_command "open_file_with_encoding" [|s|])
    in
    on_active_window_lwt g ()
  else if len < 2 then
      let g w =
        let f s = Commands.launch_command "open_file_with_encoding" [| args.(0); s |] in
        Misc.select_string w#minibuffer
          ~title: (Printf.sprintf "Open %s with encoding" (Misc.filename_to_utf8 args.(0)))
          ~choices: Iconv.encoding_names
          "" f
      in
      on_active_window_lwt g ()
    else
      let g (w : gui_window) =
        w#open_file ~attributes: ["encoding", args.(1)] args.(0);
        Lwt.return_unit
      in
      on_active_window_lwt g ()
;;

Commands.register
  { Commands.com_name = "open_file_with_encoding" ;
    Commands.com_args = [| "file"; "encoding" |] ;
    Commands.com_more_args = None ;
    Commands.com_f = open_file_with_encoding;
  }
;;


let prompt_command_history = Minibuffer.history ()
let prompt_command (w : gui_window) =
  let mb = w#minibuffer in
  let on_return com =
    match Misc.no_blanks com with
      "" -> Lwt.return_unit
    | _ -> Commands.eval_command com
  in
  Lwt.async (fun () ->
     Misc.select_string
       ~history: prompt_command_history
       mb ~title: "Command"
       ~choices: (Commands.available_command_names ())
       ""
       on_return)

let unit_coms_on_active_window =
  [
    "close_active_window",  (fun w -> w#close) ;
    "new_tab", (fun w -> w#new_tab) ;
    "split_vertically", (fun w -> w#split_active_view Stk.Props.Horizontal) ;
    "split_horizontally", (fun w -> w#split_active_view Stk.Props.Vertical) ;
    "destroy_active_view", (fun w -> w#destroy_active_view) ;
    "cycle_tab", (fun w -> w#cycle_tab true) ;
    "rev_cycle_tab", (fun w -> w#cycle_tab false) ;
    "cycle_view", (fun w -> w#cycle_view) ;
    "pop_last_hidden_view", (fun w -> w#pop_last_hidden_view) ;
    "popup_pick_hidden_view", (fun w -> w#popup_pick_hidden_view) ;
    "print_key_bindings", (fun w -> w#print_key_bindings) ;
    "paste", (fun w -> w#paste) ;
    "copy", (fun w -> w#copy) ;
    "cut", (fun w -> w#cut) ;
    "prompt_command", (fun w -> prompt_command w) ;

    Minibuffer_rc.base_name ^ "_eval", (fun w -> Lwt.async (fun () -> w#minibuffer#eval)) ;
    Minibuffer_rc.base_name ^ "_complete", (fun w -> w#minibuffer#complete) ;
    Minibuffer_rc.base_name ^ "_history_previous", (fun w -> w#minibuffer#history_previous) ;
    Minibuffer_rc.base_name ^ "_history_next", (fun w -> w#minibuffer#history_next) ;
    Minibuffer_rc.base_name ^ "_exit", (fun w -> w#minibuffer#exit ()) ;
  ]
let _ = List.iter
    (fun (name, f) ->
      Commands.register (Commands.unit_com name (on_active_window f)))
    unit_coms_on_active_window

let unit_coms_on_active_window_lwt =
  [
    "save_active_view", (fun w -> w#save_active_view) ;
    "save_active_view_as", (fun w -> w#save_active_view_as) ;
    "reload_active_view", (fun w -> w#reload_active_view) ;
  ]
let _ = List.iter
    (fun (name, f) ->
      Commands.register (Commands.unit_com_lwt name (on_active_window_lwt f)))
    unit_coms_on_active_window_lwt

let args_coms_on_active_window =
  [
    "set_active_state_message", [| "message" |],
    (fun w args -> w#set_state_message (if Array.length args > 0 then args.(0) else "")) ;

    "set_active_action_message", [| "message" |],
    (fun w args -> w#set_action_message (if Array.length args > 0 then args.(0) else ""));

    Minibuffer_rc.base_name ^ "_eval_custom_key_binding", [| "binding" |],
    (fun w args -> if Array.length args > 0 then w#minibuffer#eval_custom_key_binding args.(0)) ;

    Minibuffer_rc.base_name ^ "_insert", [| "string" |],
    (fun w args -> if Array.length args > 0 then w#minibuffer#insert args.(0)) ;
  ]

let _ = List.iter
    (fun (name,args, f) ->
      Commands.register (Commands.create_com name args (on_active_window_args f)))
    args_coms_on_active_window