(**************************************************************************)
(*                   Cameleon                                             *)
(*                                                                        *)
(*      Copyright (C) 2002 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 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 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                                *)
(**************************************************************************)

(** The modules view *)

module M = Cam_messages
module G = Gpattern

let (!!) = Options.(!!)

(** The table to get the dump of a dir. *)
let dumps = (Hashtbl.create 13 : (string, Odoc_info.Module.t_module list) Hashtbl.t)

(** The table to get the list of expanded nodes from a dir. *)
let expanded = (Hashtbl.create 13 : (string, string list) Hashtbl.t)


let remove_expanded dir name = 
  try 
    let l = Hashtbl.find expanded dir in
    let l2 = List.filter ((<>) name) l in
    Hashtbl.remove expanded dir;
    Hashtbl.add expanded dir l2
  with Not_found -> 
    ()

let add_expanded dir name =
  try
    let l = Hashtbl.find expanded dir in
    let l2 = if List.mem name l then l else name :: l in
    Hashtbl.remove expanded dir;
    Hashtbl.add expanded dir l2
  with
    Not_found ->
      Hashtbl.add expanded dir [name]

let is_expanded dir name = 
  try List.mem name (Hashtbl.find expanded dir)
  with Not_found -> false

open Odoc_info.Module
open Odoc_info.Class
open Odoc_info.Type
open Odoc_info.Value
module N =  Odoc_info.Name
open Odoc_info.Exception

let f_edit filename pos () =
  match Cam_data.data#file_of_string filename with
    None -> ()
  | Some file ->
      Cam_edit.edit Cam_data.data ~char: pos file

type element = ME of module_element | CE of class_element

class ele_list () =
  object(self)
    inherit [element] Gpattern.plist `SINGLE 
	[ M.kind ; M.name ; M.description ]
	true

    method string_of_info_opt iopt =
      match iopt with
	None -> ""
      |	Some i -> Odoc_info.string_of_info i

    method short_type t =
      let s = Odoc_info.string_of_type_expr t in
      let len = String.length s in
      if len > 20 then
	(String.sub s 0 17)^"..."
      else
	s

    method content ele =
      match ele with
	ME me ->
	  (
	   match me with
	   | Element_value v -> 
	       ([ G.String "val" ;
		  G.String (N.simple v.val_name) ;
		  G.String (self#string_of_info_opt v.val_info) ;
		],
		Some (`NAME !!Cam_config.color_view_value))
	   | Element_exception e -> 
	       ([ G.String "exception" ;
		  G.String (N.simple e.ex_name) ;
		  G.String (self#string_of_info_opt e.ex_info) ;
		],
		Some (`NAME !!Cam_config.color_view_exception))
	   | Element_type t -> 
	       ([ G.String "type" ;
		  G.String (N.simple t.ty_name) ;
		  G.String (self#string_of_info_opt t.ty_info) ;
		],
		Some (`NAME !!Cam_config.color_view_type))
	   | _ -> assert false
	  )
      | CE ce ->
	  match ce with
	  | Class_attribute a -> 
	      ([ G.String "val" ;
		 G.String (N.simple a.att_value.val_name) ;
		 G.String (self#string_of_info_opt a.att_value.val_info) ;
	       ],
	       Some (`NAME !!Cam_config.color_view_value))
	  | Class_method m -> 
	      ([ G.String "method" ;
		 G.String (N.simple m.met_value.val_name) ;
		 G.String (self#string_of_info_opt m.met_value.val_info) ;
	       ],
	       Some (`NAME !!Cam_config.color_view_value))
	  | _ -> assert false

    method compare e1 e2 = compare e1 e2

    method menu =
      match self#selection with
	[] -> []
      |	e :: q ->
	  let commands loc = 
	    (match loc.Odoc_info.loc_impl with
	      None -> []
	    | Some (file, char) -> [`I (Cam_messages.implementation, f_edit file char) ]) @
	    (match loc.Odoc_info.loc_inter with
	      None -> []
	    | Some (file, char) -> [`I (Cam_messages.interface, f_edit file char) ]) 
	  in
	  match e with
	    ME (Element_value v) -> commands v.val_loc
	  | ME (Element_type t) -> commands t.ty_loc
	  | ME (Element_exception e) -> commands e.ex_loc
	  | CE (Class_attribute a) -> commands a.att_value.val_loc
	  | CE (Class_method m) -> commands m.met_value.val_loc
	  | _ -> []

  end

class view () =
  let vbox = GPack.vbox () in
  let wl_mes = GMisc.label ~text: "" ~packing: (vbox#pack ~expand: false) () in
  let wpane = GPack.paned `HORIZONTAL ~packing: (vbox#pack ~expand: true) () in
  let wscroll = GBin.scrolled_window
      ~hpolicy: `AUTOMATIC
      ~vpolicy: `AUTOMATIC
      ~packing: (wpane#add1) () in
  let wtree = GTree.tree ~packing:wscroll#add_with_viewport () in
  let _ = wscroll#misc#set_geometry ~width: 200 () in
  let wb_refresh = GButton.button 
      ~label: M.refresh
      ~packing:(vbox#pack ~expand: false) () 
  in
  let tooltips = GData.tooltips () in
  let list_ele = new ele_list () in
  let _ = wpane#add2 list_ele#box in
  object (self)
    val mutable current_dir = None

    method string_dir =
      match current_dir with
	None -> ""
      |	Some d -> d

    method coerce = vbox#coerce

    method private clear_tree =
      List.iter wtree#remove wtree#children;
      list_ele#update_data []

    method add_contextual_menu item loc =
      let commands =
	(match loc.Odoc_info.loc_impl with
	  None -> []
	| Some (file, char) -> [`I (Cam_messages.implementation, f_edit file char) ]) @
	(match loc.Odoc_info.loc_inter with
	  None -> []
	| Some (file, char) -> [`I (Cam_messages.interface, f_edit file char) ]) 
      in
      match commands with
	[] -> ()
      |	l ->
	  (* connect the press on button 3 for contextual menu *)
          ignore(item#event#connect#button_press ~callback:
		   (
		    fun ev ->
		      GdkEvent.Button.button ev = 3 &&
		      GdkEvent.get_type ev = `BUTTON_PRESS &&
		      (
                       GToolbox.popup_menu 
			 ~button: 3
			 ~time: 0
			 ~entries: l;
		       true
		      )
		   )
		)

    method set_item_color item color =
      let style = (List.hd item#children)#misc#style#copy in
      style#set_fg
	(List.map 
	   (fun s -> (s, `NAME color))
	   [ `NORMAL;`ACTIVE;`PRELIGHT;`SELECTED;`INSENSITIVE ]
	);
      (List.hd item#children)#misc#set_style style
      

    method insert_module_ele wt ele =
      match ele with
	| Element_module m -> self#insert_module wt m
	| Element_module_type mt -> self#insert_module_type wt mt
	| Element_class c -> self#insert_class wt c
	| Element_class_type ct -> self#insert_class_type wt ct
	| _ -> ()

    method set_item_tip item info =
      match info with
	None -> ()
      |	Some i ->
	  tooltips#set_tip item#coerce ~text: (Odoc_info.string_of_info i)

    method separate_class_elements l =
      let l1 = ref [] in
      List.iter
	(fun e ->
	  match e with
	    Class_attribute _
	  | Class_method _ -> l1 := (CE e) :: !l1
	  | _ -> ()
	)
	l;
      List.rev !l1

    method insert_class wt (c : t_class) =
      let item = GTree.tree_item ~label: ("class "^(N.simple c.cl_name)) () in
      wt#append item;
      self#set_item_color item !!Cam_config.color_view_class;
      self#set_item_tip item c.cl_info ;
      self#add_contextual_menu item c.cl_loc;
      let l_eles = self#separate_class_elements (class_elements c) in
      ignore(item#connect#select (fun () -> list_ele#update_data l_eles));
      ignore(item#connect#deselect (fun () -> list_ele#update_data []));

    method insert_class_type wt (ct : t_class_type) =
      let item = GTree.tree_item ~label: ("class type "^(N.simple ct.clt_name)) () in
      wt#append item;
      self#set_item_color item !!Cam_config.color_view_class;
      self#set_item_tip item ct.clt_info ;
      self#add_contextual_menu item ct.clt_loc;
      let l_eles = self#separate_class_elements (class_type_elements ct) in
      ignore(item#connect#select (fun () -> list_ele#update_data l_eles));
      ignore(item#connect#deselect (fun () -> list_ele#update_data []));

    method separate_module_elements l =
      let l1 = ref [] in
      let l2 = ref [] in
      List.iter
	(fun e ->
	  match e with
	    Element_value _ 
	  | Element_type _ 
	  | Element_exception _ -> l2 := (ME e) :: !l2
	  | Element_module _
	  | Element_module_type _
	  | Element_class _
	  | Element_class_type _ -> l1 := e :: !l1
	  | _ -> ()
	)
	l;
      (List.rev !l1, List.rev !l2)

    method insert_module ?(top=false) wt (m : t_module) =
      let item = GTree.tree_item 
	  ~label: ((if top then "" else "module ")^(N.simple m.m_name)) () 
      in
      wt#append item;
      self#set_item_color item !!Cam_config.color_view_module;
      self#set_item_tip item m.m_info ;
      self#add_contextual_menu item m.m_loc;
      let (l_subs, l_eles) = self#separate_module_elements (module_elements m) in
      (match l_subs with
	[] -> ()
      |	_ ->
	  let wt_sub = GTree.tree () in
	  item#set_subtree wt_sub;
	  let filled = ref false in
	  ignore (item#connect#expand
		    (fun () ->
		      if not !filled then
			(
			 List.iter (self#insert_module_ele wt_sub) l_subs;
			 filled := true
			);
		      add_expanded self#string_dir m.m_name
		    )
		 );
	  ignore(item#connect#collapse
		   (fun () -> remove_expanded self#string_dir m.m_name));
	  if is_expanded self#string_dir m.m_name then
	    item#expand ()
      );
      ignore(item#connect#select (fun () -> list_ele#update_data l_eles));
      ignore(item#connect#deselect (fun () -> list_ele#update_data []));

    method insert_module_type wt (mt : t_module_type) =
      let item = GTree.tree_item ~label: ("module type "^(N.simple mt.mt_name)) () in
      wt#append item;
      self#set_item_color item !!Cam_config.color_view_module;
      self#set_item_tip item mt.mt_info ;
      self#add_contextual_menu item mt.mt_loc;
      let (l_subs, l_eles) = self#separate_module_elements (module_type_elements mt) in
      (match l_subs with
	[] -> ()
      |	_ ->
	  let wt_sub = GTree.tree () in
	  item#set_subtree wt_sub;
	  let filled = ref false in
	  ignore (item#connect#expand
		    (fun () ->
		      if not !filled then
			(
			 List.iter (self#insert_module_ele wt_sub) l_subs;
			 filled := true
			);
		      add_expanded self#string_dir mt.mt_name
		    )
		 );
	  ignore(item#connect#collapse
		   (fun () -> remove_expanded self#string_dir mt.mt_name));
	  if is_expanded self#string_dir mt.mt_name then
	    item#expand ()
      );
      ignore(item#connect#select (fun () -> list_ele#update_data l_eles));
      ignore(item#connect#deselect (fun () -> list_ele#update_data []));

    method refresh ?(force=false) () = 
      self#clear_tree ;
      match current_dir with
	None -> ()
      |	Some dir ->
	  Hashtbl.remove dumps dir;
	  wl_mes#set_text "";
	  let dump_file = Filename.concat dir "dump.odoc" in
	  if force or not (Sys.file_exists dump_file) then
	    ignore(Sys.command ("cd "^dir^" ; make dump.odoc"));
	  try
	    let modules = Odoc_info.load_modules dump_file in
	    Hashtbl.add dumps dir modules;
	    List.iter (self#insert_module ~top: true wtree) modules
	  with
	    Failure s ->
	      prerr_endline s;
	      wl_mes#set_text ("no module information in "^dir)

    method display_dir (dir_opt : string option) =
      if current_dir = dir_opt then
	()
      else
	(
	 current_dir <- dir_opt;
	 wl_mes#set_text "";
	 self#clear_tree ;
	 match dir_opt with
	   None -> ()
	 | Some dir ->
	     try
	       let modules = Hashtbl.find dumps dir in
	       List.iter (self#insert_module ~top: true wtree) modules
	     with
	       Not_found ->
		 self#refresh ()
	)

    initializer
      ignore(wb_refresh#connect#clicked (self#refresh ~force: true))
  end
