(*********************************************************************************)

(*                Cameleon                                                       *)
(*                                                                               *)
(*    Copyright (C) 2005,2006 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 Library General Public License as            *)
(*    published by the Free Software Foundation; either version 2 of the         *)
(*    License, or  any later version.                                            *)
(*                                                                               *)
(*    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 Library General Public License for more details.                       *)
(*                                                                               *)
(*    You should have received a copy of the GNU Library 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                                          *)
(*                                                                               *)
(*********************************************************************************)


type command = string

type menu =
    { mutable mn_label : string ;
      mutable mn_children : menu_item list;
      mutable mn_doc : bool ;
    }

and menu_item_info =
    { mutable mii_label : string ;
      mutable mii_command : command ;
      mutable mii_stock_image : string option ;
    }

and menu_item =
    Submenu of menu
  | Command of menu_item_info
  | Separator

(**

Default menus

*)


let default_menus =
  [
    { mn_label = Cam_messages.file ;
      mn_doc = false ;
      mn_children =
      [
        Command
          { mii_label = Cam_messages.log_window ;
            mii_command = Cam_constant.com_log_window ;
            mii_stock_image = None ;
          }        ;
        Separator ;
        Command
          { mii_label = Cam_messages.quit ;
            mii_command = Cam_constant.com_quit ;
            mii_stock_image = Some (GtkStock.convert_id `QUIT);
          }        ;
      ] ;
    } ;

    { mn_label = Cam_messages.doc ;
      mn_doc = true ;
      mn_children = [] ;
    } ;

    { mn_label = "Configure" ;
      mn_doc = false ;
      mn_children =
      [
        Command
          { mii_label = "Menus" ;
            mii_command = Cam_constant.com_configure_menus ;
            mii_stock_image = None ;
          } ;
        Command
          { mii_label = "Button bar" ;
            mii_command = Cam_constant.com_configure_bbar ;
            mii_stock_image = None ;
          } ;
        Command
          { mii_label = Cam_messages.common_keyboard_shortcuts ;
            mii_command = Cam_constant.com_configure_common_keyboard_shortcuts ;
            mii_stock_image = None ;
          } ;
        Command
          { mii_label = Cam_messages.file_types_rules ;
            mii_command = Cam_constant.com_configure_ft_rules ;
            mii_stock_image = None ;
          } ;
        Command
          { mii_label = Cam_messages.file_types_handlers ;
            mii_command = Cam_constant.com_configure_ft_handlers ;
            mii_stock_image = None ;
          } ;
        Command
          { mii_label = Cam_messages.plugins ;
            mii_command = Cam_constant.com_configure_plugins ;
            mii_stock_image = None ;
          } ;
        Command
          { mii_label = Cam_messages.doc_sources ;
            mii_command = Cam_constant.com_configure_doc_sources ;
            mii_stock_image = None ;
          } ;
        Command
          { mii_label = Cam_messages.docbrowser_keyboard_shortcuts ;
            mii_command = Cam_constant.com_configure_docbrowser_keyboard_shortcuts ;
            mii_stock_image = None ;
          } ;
      ]        ;
    } ;
    { mn_label = "?" ;
      mn_doc = false ;
      mn_children =
      [
        Command
          { mii_label = Cam_messages.about ;
            mii_command = Cam_constant.com_about_box ;
            mii_stock_image = None ;
          } ;
      ]
    } ;
  ]

(**

Storing

*)


open Xml
exception Bad_format of xml

let rec xml_of_menu m =
  Element ("menu",
           ("label", m.mn_label):: (if m.mn_doc then ["doc","true"else []),
           List.map xml_of_menu_item m.mn_children
          )

and xml_of_command c =
  Element ("command",
           ["label", c.mii_label ; "command", c.mii_command] @
           (match c.mii_stock_image with None -> [] | Some s -> ["stock", s]),
           [])

and xml_of_separator = Element ("separator", [], [])

and xml_of_menu_item = function
    Submenu m -> xml_of_menu m
  | Command mii -> xml_of_command mii
  | Separator -> xml_of_separator

let string_of_menu l =
  Xml.to_string (xml_of_menu l)

let rec menu_item_list_of_xmls l =
  List.rev
    (List.fold_left
       (fun acc xml ->
         match menu_item_opt_of_xml xml with
           None -> acc
         |        Some mi -> mi :: acc
       )
       []
       l
    )

and menu_item_opt_of_xml xml =
  match xml with
    Element ("menu", atts, subs) ->
      (
       try
         let label = Xml.attrib xml "label" in
         let doc =
           try Xml.attrib xml "doc" = "true"
           with _ -> false
         in
         let ch = menu_item_list_of_xmls subs in
         Some
           (Submenu { mn_label = label ;
                      mn_doc = doc ;
                      mn_children = ch ;
                    }
           )
       with
         Not_found ->
           raise (Bad_format xml)
      )
  | Element ("command", atts, _) ->
      (
       try
         let label = Xml.attrib xml "label" in
         let com = Xml.attrib xml "command" in
         let stock =
           try Some (Xml.attrib xml "stock")
           with _ -> None
         in
         Some (Command { mii_label = label ;
                         mii_command = com ;
                         mii_stock_image = stock ;
                       }
              )
       with
         Not_found ->
           raise (Bad_format xml)
      )
  | Element ("separator",_,_) ->
      Some Separator
  | _ ->
      None

let menu_of_xml xml =
  match menu_item_opt_of_xml xml with
    Some (Submenu m) -> m
  | _ -> raise (Bad_format xml)

let menus_of_source source =
  try
    let t_parser = XmlParser.make () in
    let _ = XmlParser.prove t_parser false in
    let xml = XmlParser.parse t_parser source in
    match xml with
      Element ("menus", _, subs) -> List.map menu_of_xml subs
    | _ -> raise (Bad_format xml)
  with
    Bad_format xml ->
      let s = Cam_misc.chop_n_char 120 (Xml.to_string xml) in
      failwith (Cam_messages.bad_format s)

let xml_of_menus l =
  Element ("menus", [], List.map xml_of_menu l)

let string_of_menus l = Xml.to_string_fmt (xml_of_menus l)

let rc_file = Filename.concat Cam_rc.rc_dir "menus.xml"

let write_menus menus =
  Cam_misc.file_of_string ~file: rc_file (string_of_menus menus)

let menus_of_file file =
  try menus_of_source (XmlParser.SFile file)
  with
    Sys_error s
  | Failure s ->
      prerr_endline s ;
      default_menus
  | Xml.File_not_found _ ->
      let m = default_menus in
      write_menus m;
      m

(**

Configuring

*)


let clipboard = ref (None : menu_item option)
module C = Configwin
module M = Cam_messages

let params_menu_item mi =
  match mi with
    Separator -> []
  | Command mii ->
      let coms = Cam_commands.available_command_names () in
      let param_label = C.string
          ~f: (fun s -> mii.mii_label <- s)
          M.label
          mii.mii_label
      in
      let param_command = C.combo
          ~f: (fun s -> mii.mii_command <- s)
          ~new_allowed: true
          ~blank_allowed: false
          M.command
          coms
          mii.mii_command
      in
      [ param_label ; param_command ]
  | Submenu m ->
      let param_label = C.string
          ~f: (fun s -> m.mn_label <- s)
          M.label
          m.mn_label
      in
      let param_doc = C.bool
          ~f: (fun b -> m.mn_doc <- b)
          M.doc_flag
          m.mn_doc
      in
      [ param_label ; param_doc ]

let rec copy_menu m =
  { mn_label = m.mn_label ;
    mn_doc = m.mn_doc ;
    mn_children = List.map copy_menu_item m.mn_children ;
  }

and copy_menu_item mi =
  match mi with
    Separator -> Separator
  | Command i -> Command { mii_label = i.mii_label ;
                           mii_command = i.mii_command ;
                           mii_stock_image = i.mii_stock_image ;
                         }
  | Submenu m -> Submenu (copy_menu m)

class menu_config_box f_update () =
  let hbox = GPack.hbox () in
  let wscroll = GBin.scrolled_window
      ~hpolicy: `AUTOMATIC
      ~vpolicy: `AUTOMATIC
      ~packing: (hbox#pack ~expand: true)
      ()
  in

  let cols = new GTree.column_list in
  let col_display = cols#add Gobject.Data.string in
  let (col_data: menu_item GTree.column) = cols#add Gobject.Data.caml in

  let store = GTree.tree_store cols in
  let tv = GTree.view ~model: store ~packing:wscroll#add_with_viewport () in
  let col = GTree.view_column ()
      ~renderer:(GTree.cell_renderer_text [], ["text", col_display]) in
  let () = ignore (tv#append_column col) in

  let vbox = GPack.vbox ~packing: (hbox#pack ~expand: false ~padding: 4) () in
  let wb_copy = GButton.button ~label: M.copy
      ~packing: (vbox#pack ~expand: false ~padding: 2) () in
  let wb_cut = GButton.button ~label: M.cut
        ~packing: (vbox#pack ~expand: false ~padding: 2) () in
  let wb_paste = GButton.button ~label: M.paste
        ~packing: (vbox#pack ~expand: false ~padding: 2) () in
  let wb_edit = GButton.button ~label: M.edit
        ~packing: (vbox#pack ~expand: false ~padding: 2) () in
  let wb_up = GButton.button ~label: M.up
        ~packing: (vbox#pack ~expand: false ~padding: 2) () in
  let wb_down = GButton.button ~label: M.down
        ~packing: (vbox#pack ~expand: false ~padding: 2) () in
  let wb_add = GButton.button ~label: M.add
        ~packing: (vbox#pack ~expand: false ~padding: 2) () in

  object (self)
    val mutable menus =
      List.map copy_menu (menus_of_file rc_file)
    method box = hbox
    method apply () : unit =
      let menus =  self#build_menus () in
      write_menus menus;
      f_update ()

    method selected_rr =
       match tv#selection#get_selected_rows with
      | [] -> None
      | path :: _ -> Some (store#get_row_reference path)

    method insert_in_selected ele =
      match self#selected_rr with
        None -> self#insert_menu_item ele
      | Some rr -> self#insert_menu_item ~parent: rr ele

    method string_of_menu_item mi =
      match mi with
        Submenu m -> self#string_of_menu m
      | Command mii -> self#string_of_menu_item_info mii
      | Separator -> self#string_of_separator

    method string_of_menu m =
      Printf.sprintf "%s%s"
        (if m.mn_doc then "["^Cam_messages.doc^"]" else "")
        m.mn_label

    method string_of_menu_item_info mii =
      mii.mii_label^" ["^mii.mii_command^"]"
   method string_of_separator =
      "-----------------"

    method insert_menu_item ?parent ?pos mi =
      let row =
        match pos with
          None -> store#append ?parent: (Cam_misc.map_opt (fun rr -> rr#iter) parent) ()
        | Some pos -> store#insert ?parent: (Cam_misc.map_opt (fun rr -> rr#iter) parent) pos
      in
      let iter_rr rr = store#get_row_reference (store#get_path rr) in
      match mi with
        Submenu m ->
          store#set row col_display (self#string_of_menu m);
          store#set row col_data (Submenu { m with mn_children = [] });
          List.iter (self#insert_menu_item ~parent: (iter_rr row)) m.mn_children

      | Command mii ->
          store#set row col_display (self#string_of_menu_item_info mii);
          store#set row col_data (Command { mii with mii_label = mii.mii_label })

      | Separator ->
          store#set row col_display self#string_of_separator;
          store#set row col_data Separator

    method show_menus menus =
      store#clear ();
      List.iter self#insert_menu_item (List.map (fun m -> Submenu m) menus)

    method get_children (it_opt : Gtk.tree_iter option) =
      let first =
        match it_opt with
          None -> store#get_iter_first
        | Some it ->
            if store#iter_has_child it then
              Gstuff.find_first_child store it
            else
              None
      in
      match first with
        None -> []
      | Some it ->
          let rr it = store#get_row_reference (store#get_path it) in
          let rec f acc it =
            if store#iter_next it then
              f (rr it :: acc) it
            else
              List.rev acc
          in
          f [rr it] it

    method build_menus () =
      List.fold_left
        (fun acc row ->
          match self#build_menu_item row with
            Submenu m -> acc @ [m]
          | _ -> acc
        )
        []
        (self#get_children None)

    method build_menu_item row =
      let rec build rr =
        let it = rr#iter in
        match store#get ~row: it ~column: col_data with
          Submenu m ->
            Submenu
              { m with
               mn_children = List.map build
                  (self#get_children (Some rr#iter))
              }
        | Command mii ->
            Command { mii with mii_label = mii.mii_label }
        | Separator ->
            Separator
      in
      build row


    method edit () =
      match self#selected_rr with
        None -> ()
      | Some rr ->
          let row = rr#iter in
          let mi = store#get ~row ~column: col_data in
          match mi with
            Separator -> ()
          | _ ->
              match C.simple_get M.edit (params_menu_item mi) with
                C.Return_cancel -> ()
              | C.Return_apply
              | C.Return_ok ->
                  store#set ~row ~column: col_display (self#string_of_menu_item mi)

    method copy () =
      match self#selected_rr with
        None -> ()
      | Some rr ->
          clipboard := Some (self#build_menu_item rr)

    method delete ?(cut=false) () =
      match self#selected_rr with
        None -> ()
      | Some rr ->
          if cut then clipboard := Some (self#build_menu_item rr);
          ignore (store#remove rr#iter) ;
          tv#selection#unselect_all ()

    method paste () =
      match !clipboard with
        None -> ()
      | Some mi ->
          let rr = self#selected_rr in
          match rr with
            None ->
              (
               match mi with
                 Submenu m ->
                   self#insert_menu_item mi ;
                   tv#selection#unselect_all ()
               | Separator | Command _ -> ()
              )
          | Some rr ->
              match store#get ~row: rr#iter ~column: col_data with
                Separator | Command _ -> ()
              | _ ->
                  self#insert_menu_item ~parent: rr mi ;
                  tv#selection#unselect_all ()
    method move_up () =
      match self#selected_rr with
      None -> ()
      | Some rr ->
          let row = rr#iter in
          match Gstuff.find_iter_above store#coerce row with
            None -> ()
          | Some rr2 ->
              let it1 = store#get_iter rr#path in
              let it2 = rr2#iter in
              ignore (store#swap it1 it2)

    method move_down () =
      match self#selected_rr with
        None -> ()
      | Some rr ->
          let row = rr#iter in
          match Gstuff.find_iter_below store row with
            None -> ()
          | Some rr2 ->
              let it1 = store#get_iter rr#path in
              let it2 = rr2#iter in
              ignore (store#swap it1 it2)

    method add_menu_item title mi =
      match C.simple_get title (params_menu_item mi) with
        C.Return_cancel -> ()
      | C.Return_apply
      | C.Return_ok ->
          let b = !clipboard in
          clipboard := Some mi;
          self#paste ();
          clipboard := b

    method add_menu () =
      let m = { mn_label = "" ;
                mn_doc = false ;
                mn_children = [] }
      in
      self#add_menu_item M.add_menu (Submenu m)

    method add_command () =
      let c = { mii_label = "" ;
                mii_command = Cam_constant.com_new_file ;
                mii_stock_image = None;
              }
      in
      self#add_menu_item M.add_command (Command c)

    method add_separator () =
      let b = !clipboard in
      clipboard := Some Separator;
      self#paste ();
      clipboard := b

    method add_select () =
      let choices =
        match self#selected_rr with
          None -> [ M.menu, self#add_menu ]
        | Some rr ->
            let row = rr#iter in
            match store#get ~row ~column: col_data with
              Submenu m ->
                [ M.menu, self#add_menu ;
                  M.command, self#add_command ;
                  M.separator, self#add_separator ]
            | Command _ | Separator ->
                []
      in
      match choices with
        [] -> ()
     | l ->
          GToolbox.popup_menu ~button: 1 ~time: Int32.zero
            ~entries: (List.map (fun (l,f) -> `I (l,f)) l)

    initializer
      self#show_menus menus;
      ignore (wb_copy#connect#clicked self#copy);
      ignore (wb_cut#connect#clicked (self#delete ~cut: true));
      ignore (wb_paste#connect#clicked self#paste);
      ignore (wb_edit#connect#clicked self#edit);
      ignore (wb_up#connect#clicked self#move_up);
      ignore (wb_down#connect#clicked self#move_down);
      ignore (wb_add#connect#clicked self#add_select);
  end


(**

Creating menu in GUI

*)


let doc_menu = ref (GMenu.menu ())

let rec create_menu_item menu mi =
  let item =
    match mi with
      Command mii ->
        let i = GMenu.image_menu_item
            ?stock: (Cam_misc.map_opt (fun s -> `STOCK s) mii.mii_stock_image)
            ~label: mii.mii_label ()
        in
        (
         try
           let t = Cam_commands.string_to_argv mii.mii_command in
           let len = Array.length t in
           if len <= 0 then
             ()
           else
             let com = t.(0) in
             let args = Array.sub t 1 (len - 1) in
             ignore (i#connect#activate
                       (fun () -> Cam_commands.launch_command com args))
         with
           Not_found ->
             i#misc#set_sensitive false
        );
        i
    | Submenu mn ->
        let i = GMenu.image_menu_item ~label: mn.mn_label () in
        let m = GMenu.menu () in
        i#set_submenu m;
        List.iter (create_menu_item m) mn.mn_children;
        if mn.mn_doc then doc_menu := m;
        i
    | Separator ->
        let i = GMenu.image_menu_item () in
        i
  in
  menu#append (item :> GMenu.menu_item)

let create_menu menubar m =
  let menu = GMenu.menu () in
  let item = GMenu.image_menu_item ~label: m.mn_label ~packing: menubar#add () in
  item#set_submenu menu;
  List.iter (create_menu_item menu) m.mn_children;
  if m.mn_doc then doc_menu := menu

let update_doc_menu load_doc =
  Cam_doc.update load_doc Cam_doc.default_doc_modules
    Cam_doc_gui.open_element
    Cam_doc_gui.search_exact
    Cam_doc_gui.search_regexp
    !doc_menu;
  Gc.compact ();
  match !Cam_doc_gui.modules_window with
    None -> ()
  | Some _ -> Cam_doc_gui.create_or_update_list_window Cam_doc.default_doc_modules

let main_menu_bar = ref None

let update_menus ?(load_doc=false) (menubar : GMenu.menu_shell) =
  main_menu_bar := Some menubar;
  List.iter menubar#remove menubar#children;
  let menus = menus_of_file rc_file in
  List.iter
    (create_menu menubar)
    menus;
  update_doc_menu load_doc

let _configure_menus args =
  match !main_menu_bar with
    None -> ()
  | Some mbar ->
      let box = new menu_config_box (fun () -> update_menus mbar) () in
      let p = C.custom box#box box#apply true in
      ignore (C.simple_get "Menu config" [p])

let _ = Cam_commands.register
    { Cam_commands.com_name = Cam_constant.com_configure_menus ;
      Cam_commands.com_args = [| |] ;
      Cam_commands.com_more_args = None ;
      Cam_commands.com_f = _configure_menus ;
    }