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


let layout_file = ref (Config.local_dir_rc_file "layout.xml")

type  layout_view = {
    lv_kind : string ;
    lv_file : string ;
    lv_atts : (string * string) list ;
    lv_subs : Xml.t list ;
  }

type layout_contents = [
    `View of layout_view
  | `Paned of layout_paned
  | `Notebook of layout_notebook
  ]

and layout_paned = {
    lp_orientation : Stk.Props.orientation ;
    lp_position : int ;
    lp_children : layout_contents * layout_contents ;
  }

and layout_notebook = {
    ln_tabs : layout_contents list ;
  }


type layout_window = {
    lw_x : int ;
    lw_y : int ;
    lw_w : int ;
    lw_h : int ;
    lw_contents : layout_contents option ;
  }

type layout = layout_window list

let xml_of_layout_view lv =
  let atts =
    (("", "kind"), lv.lv_kind) ::
      (("", "file"), lv.lv_file) ::
      (List.map (fun (a, v) -> ("",a), v) lv.lv_atts)
  in
  Xml.E ((("", "view"), atts), [])

let rec xml_of_layout_contents = function
    `View v -> xml_of_layout_view v
  | `Paned p -> xml_of_layout_paned p
  | `Notebook n -> xml_of_layout_notebook n

and xml_of_layout_paned lp =
  let atts =
    [ ("", "orientation"),
        (match lp.lp_orientation with
         | Stk.Props.Vertical -> "vertical"
         | Horizontal -> "horizontal") ;
      ("", "position"), string_of_int lp.lp_position ;
    ]
  in
  let children =
    let (c1, c2) = lp.lp_children in
    [ xml_of_layout_contents c1 ;
      xml_of_layout_contents c2 ;
    ]
  in
  Xml.E ((("","paned"), atts), children)

and xml_of_layout_notebook ln =
  let children = List.map xml_of_layout_contents ln.ln_tabs in
  Xml.E((("","notebook"), []), children)

let xml_of_layout_window lw =
  let atts =
    [ ("", "x"), string_of_int lw.lw_x ;
      ("", "y"), string_of_int lw.lw_y ;
      ("", "width"), string_of_int lw.lw_w ;
      ("", "height"), string_of_int lw.lw_h ;
    ]
  in
  let children =
    match lw.lw_contents with
      None -> []
    | Some c -> [xml_of_layout_contents c]
  in
  Xml.E((("","window"), atts), children)

let xml_of_layout wins =
  Xml.E((("","layout"), []), List.map xml_of_layout_window wins)

let store_layout file wins =
  let xml = xml_of_layout wins in
  let s = Xml.string_of_xml xml in
  Misc.file_of_string ~file s


let map_opt f = function
    None -> None
  | Some v -> Some (f v)

let string_opt_att name l =
  try Some (snd (List.find (fun ((_,n),_) -> n = name) l))
  with Not_found -> None
;;

let string_att name l =
  match string_opt_att name l with
    None -> failwith ("Attribute "^name^" not found")
  | Some s -> s

let int_att name l =
  let v = string_att name l in
  try int_of_string v
  with Invalid_argument _ ->
    failwith ("Bad value for attribute "^name^": "^v)

let remove_common_view_atts atts =
  let atts = List.map (fun ((_,a),v) -> (a, v)) atts in
  List.filter (fun (s,_) -> s <> "kind" && s <> "file") atts
;;

let rec layout_contents_of_xml = function
    Xml.E ((("","view"),atts),subs) ->
      `View { lv_kind = string_att "kind" atts ;
              lv_file = string_att "file" atts ;
              lv_atts = remove_common_view_atts atts ;
              lv_subs = subs ;
            }
  | Xml.E ((("","paned"),atts),l) ->
      let o =
        match string_att "orientation" atts with
          "vertical" -> Stk.Props.Vertical
        | "horizontal" -> Horizontal
        | s -> failwith ("Invalid orientation: "^s)
      in
      let p = int_att "position" atts in
      let children =
        match l with
          e1 :: e2 :: _ ->
            (layout_contents_of_xml e1,
             layout_contents_of_xml e2)
        | _ -> failwith "Invalid children for paned"
      in
      `Paned { lp_orientation = o;
               lp_position = p;
               lp_children = children ;
             }

  | Xml.E ((("","notebook"),_),l) ->
      `Notebook { ln_tabs = List.map layout_contents_of_xml l}
  | _ -> failwith "Invalid contents layout"

let layout_window_of_xml = function
    Xml.E((("","window"),atts),l) ->
      let c =
        match l with
          [] -> None
        | c :: _ -> Some (layout_contents_of_xml c)
      in
      { lw_x = int_att "x" atts ;
        lw_y = int_att "y" atts ;
        lw_w = int_att "width" atts ;
        lw_h = int_att "height" atts ;
        lw_contents = c ;
      }
| Xml.E (((s1,s2),_),l) ->
    prerr_endline (Printf.sprintf "Xml.E (%s, %s)" s1 s2);
    failwith "Invalid window layout"
| Xml.D data ->
    prerr_endline (Printf.sprintf "Xml.D %S" data);
    failwith "Invalid window layout"

let layout_of_xml = function
  Xml.E ((("","layout"),_),l) ->
    List.map layout_window_of_xml l
| _ -> failwith "Invalid layout"

let load_layout file =
  Xml.read_xml_file file ~strip: true layout_of_xml

let rec layout_of_contents = function
    `View v ->
      `View { lv_kind = v#kind; lv_file = v#filename ;
              lv_atts = v#attributes ; lv_subs = v#xml_children }
  | `Paned p ->
      begin
        match p#child1, p#child2 with
        | None, None -> failwith "Bad paned layout"
        | None, Some x
        | Some x, None -> layout_of_contents x
        | Some a, Some b ->
            `Paned { lp_orientation = p#orientation ;
                     lp_position = p#position ;
                     lp_children = (layout_of_contents a, layout_of_contents b) ;
                   }
      end
  | `Notebook n ->
      `Notebook { ln_tabs = List.map (fun (_,c) -> layout_of_contents c) n#tabs }

let layout_of_window w =
  { lw_x = w#x ;
    lw_y = w#y ;
    lw_w = w#width ;
    lw_h = w#height ;
    lw_contents =
      match w#contents with
        None -> None
      | Some c -> Some (layout_of_contents c);
  }

let layout_of_windows = List.map layout_of_window

let rec contents_of_layout topwin = function
| `View lv ->
    begin
      let factory = lv.lv_kind in
      let v =
        let attributes = lv.lv_atts in
        let xmls = lv.lv_subs in
        match View.factory_open_file topwin ~factory None
          ~attributes ~xmls lv.lv_file
        with
        | `New_view v | `Use_view v -> v
      in
      Gui.init_view topwin v;
      (`View v, fun () -> ())
    end
| `Paned lp ->
    let (c1,after1) = contents_of_layout topwin (fst lp.lp_children) in
    let (c2,after2) = contents_of_layout topwin (snd lp.lp_children) in
    let gp = new Gui.gui_paned topwin lp.lp_orientation () in
    gp#set_one_child 1 c1;
    gp#set_one_child 2 c2;
    let after () =
      gp#set_position lp.lp_position;
      after1();
      after2();
    in
    (`Paned gp, after)
| `Notebook ln ->
    let l = List.map (contents_of_layout topwin) ln.ln_tabs in
    let tabs, afters = List.split l in
    let gn = new Gui.gui_notebook topwin () in
    List.iter (gn#add_tab None) tabs;
    let after () = List.iter (fun f -> f ()) afters in
    (`Notebook gn, after)

let create_window_of_layout lw =
  let w = Gui.create_window
      ~x: lw.lw_x ~y: lw.lw_y
      ~w: lw.lw_w ~h: lw.lw_h
      ()
  in
  let topwin = (w :> View.topwin) in
  match lw.lw_contents with
    None -> ()
  | Some lc ->
      let (c, after) = contents_of_layout topwin lc in
      let () =
        match c with
        | `View v ->
            w#add_view v;
            Gui.init_view topwin v;
            v#grab_focus
        | `Paned _
        | `Notebook _ -> w#set_contents (Some c)
      in
      after ()

let create_windows_of_layout = List.iter create_window_of_layout


let () = Commands.register
  { Commands.com_name = "window_fullscreen" ;
    com_args = [| |];
    com_more_args = None ;
    com_f = (fun _ ->
      Gui.on_active_window_lwt (fun w ->
          let open Stk.Misc in
          let> () = Tsdl.Sdl.(set_window_fullscreen w#toplevel#window Window.fullscreen) in
          Lwt.return_unit) ())
    }


let _ =
  let f args =
    let file =
      if Array.length args > 0 then
        args.(1)
      else
        !layout_file
    in
    let layout = layout_of_windows !Gui.gui_windows in
    store_layout file layout;
    Lwt.return_unit
  in
  let com =
    { Commands.com_name = "store_layout" ;
      Commands.com_args = [| "file" |] ;
      Commands.com_more_args = None ;
      Commands.com_f = f;
    }
  in
  Commands.register com