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

(*                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                                          *)
(*                                                                               *)
(*********************************************************************************)


(* $Id: cam_view.ml 342 2006-10-10 08:53:32Z zoggy $ *)

type ressource_kind = [ `None | `Dir | `File ] (* later `Module | ` Class | ... ? *)
type ressource_name = string
type view_name = string

class type view =
  object
    method name : view_name
    method refresh : unit
    method close : bool
    method changed : bool
    method ressource : ressource_name
    method ressource_kind : ressource_kind
  end

class type view_factory =
  object
    method name : view_name
    method create : ressource_name -> string array -> (view * GWindow.window)
    method create_no_window : GWindow.window -> ressource_name -> string array -> view * GObj.widget
    method known_ressource_kinds : ressource_kind list
  end

let factories = ref ([] : view_factory list)

let register_factory f =
  if List.exists (fun o -> o#name = f#name) !factories then
    Cam_dbg.print (Printf.sprintf "A view factory called \"%s\" is already registered." f#name)
  else
    factories := f :: !factories

let views : (string, (view * GWindow.window * [`Top | `Embedded]) list) Hashtbl.t = Hashtbl.create 13

let remove_view res_name v =
  try
    let l = Hashtbl.find views res_name in
    Hashtbl.replace views res_name (List.filter (fun (v2,_,_) -> Oo.id v2 <> Oo.id v) l)
  with Not_found ->
    ()

let add_view res_name (v,w,k) =
  try
    let l = Hashtbl.find views res_name in
    Hashtbl.replace views res_name ((v,w,k) :: l)
  with Not_found ->
    Hashtbl.add views res_name [(v,w,k)]

let view_window_name vname res_name =
  Printf.sprintf "%s:%s" vname res_name

let _open_ressource ?fpack res_name v_name args =
  let f =
    try List.find (fun f -> f#name = v_name) !factories
    with Not_found ->
      failwith (Printf.sprintf "No factory \"%s\"" v_name)
  in
  match fpack with
    None ->
      begin
          try
            let l = Hashtbl.find views res_name in
            match List.filter (fun (v,w,k) -> v#name = v_name && k=`Top) l with
              [] -> raise Not_found
            | (v,w,_) :: _ ->
                w#iconify () ;
                Cam_misc.treat_gtk_events ();
                w#deiconify ();
                v
          with
            Not_found ->
              let (v,w) = f#create res_name args in
              add_view res_name (v,w,`Top);
              v
      end
  | Some (w,fpack) ->
      let (v,widget) = f#create_no_window w res_name args in
      fpack widget;
      add_view res_name (v,w,`Embedded);
      v

let open_ressource res_name v_name args =
  _open_ressource res_name v_name args

let open_ressource_no_window res_name v_name args window fpack =
  _open_ressource ~fpack:(window,fpack) res_name v_name args

let iter_views f res_name =
  try
    let l = Hashtbl.find views res_name in
    List.iter
      (fun (v, w, _) ->
        try f (v, w)
        with _ -> ()
      )
      l
  with Not_found -> ()

let refresh_ressource_views = iter_views (fun (v, w) -> v#refresh)
let close_ressource_views = iter_views (fun (v, w) -> if v#close then w#destroy ())

let available_views ?kind () =
  match kind with
    None -> List.map (fun f -> f#name) !factories
  | Some k ->
      List.fold_left
        (fun acc f ->
          if List.mem k f#known_ressource_kinds then
            f#name :: acc
          else
            acc
        )
        []
        !factories

let current_focused_view_window = ref None
let current_view () = !current_focused_view_window

class view_window ?(allow_shrink=true)
    ?(width=400) ?(height=400) ~title (v:view) =
  let vname = v#name in
  let res_name = v#ressource in
  let window_name = view_window_name vname res_name in
  let w = GWindow.window ~allow_shrink ~width ~height ~title () in
  let vbox = GPack.vbox ~packing: w#add () in
(*
  let menubar = GMenu.menu_bar
    ~packing: (vbox#pack ~expand: false) ()
  in
  let i = GMenu.menu_item ~label: "View" () in
  let m = GMenu.menu () in
  let _ = i#set_submenu m in
*)


  object
    method window = w
    method vbox = vbox

    initializer
      Cam_rc.handle_window w window_name;
      ignore (w#connect#destroy
                (fun _ -> remove_view v#ressource v));
      ignore (w#event#connect#focus_in
                (fun _ -> current_focused_view_window := Some (v,w); true));
      ignore (w#event#connect#focus_out
                (fun _ -> current_focused_view_window := Nonetrue));
      Cam_keymaps.set_window_common_keymaps w
  end

let create_view_window ?width ?height ~title view =
  new view_window ?width ?height ~title view

let _command_refresh_view args =
  match current_view () with
    None -> ()
  | Some (v,_) ->
      Cam_dbg.print ~level: 3
        (Printf.sprintf "Refreshing view %s on %s" v#name v#ressource);
      v#refresh

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

let _command_close_view args =
  match current_view () with
    None -> ()
  | Some (v,w) ->
      Cam_dbg.print ~level: 3
        (Printf.sprintf "Closing view %s on %s" v#name v#ressource);
      if v#close then
        w#destroy ()

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

let _command_open_view args =
  if Array.length args < 2 then
    ()
  else
    let len = Array.length args in
    let res_name = args.(0) in
    let v_name = args.(1) in
    let args = if len > 2 then Array.sub args 2 (len - 2) else [| |] in
    ignore (open_ressource res_name v_name args)

let _ = Cam_commands.register
    { Cam_commands.com_name = "open_view" ;
      Cam_commands.com_args = [| "ressource name" ; "view name" |] ;
      Cam_commands.com_more_args = None ;
      Cam_commands.com_f = _command_open_view ;
    }

let _command_popup_view_directory_menu args =
  if Array.length args < 1 then
    ()
  else
    let root = args.(0) in
    let view_names = available_views ~kind: `Dir () in
    match view_names with
      [] -> ()
    | _ ->
        let rec entries dir =
          let l =
            List.map
              (fun s -> `I (Printf.sprintf "%s view" s, fun () -> ignore (open_ressource dir s [| |])))
              view_names
          in
          match Cam_misc.subdirs dir with
            [] -> l
          | subs ->
              l @ (`S :: (List.map (fun d -> `M (Filename.basename d, entries d)) subs))
        in
        match entries root with
          [] -> ()
        | entries -> GToolbox.popup_menu
              ~button: 1 ~time: Int32.zero
              ~entries

let _ = Cam_commands.register
    { Cam_commands.com_name = "popup_view_directory_menu" ;
      Cam_commands.com_args = [| "root directory" |] ;
      Cam_commands.com_more_args = None ;
      Cam_commands.com_f = _command_popup_view_directory_menu ;
    }