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

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


(** The modules view *)


module M = Cam_messages
module O = Config_file
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 to_utf8 s =
  try Glib.Convert.locale_to_utf8 s
  with e ->
    prerr_endline (Printf.sprintf "%s: %s" s (Printexc.to_string e));
    ""

let color_type = new O.string_cp ~group: Cam_rc.gui_ini
    ["modules_view" ; "colors" ; "type""Brown" ""

let color_value = new O.string_cp ~group: Cam_rc.gui_ini
    ["modules_view" ; "colors" ; "value""Black" ""

let color_exception = new O.string_cp ~group: Cam_rc.gui_ini
    ["modules_view" ; "colors" ; "exception""Red" ""

let color_module = new O.string_cp ~group: Cam_rc.gui_ini
    ["modules_view" ; "colors" ; "module""SlateBlue" ""

let color_module_type = new O.string_cp ~group: Cam_rc.gui_ini
    ["modules_view" ; "colors" ; "module_type""DarkSlateBlue" ""

let color_class = new O.string_cp ~group: Cam_rc.gui_ini
    ["modules_view" ; "colors" ; "class""DarkOliveGreen3" ""

let color_class_type = new O.string_cp ~group: Cam_rc.gui_ini
    ["modules_view" ; "colors" ; "class_type""DarkOliveGreen4" ""

let color_comment = new O.string_cp ~group: Cam_rc.gui_ini
    ["modules_view" ; "colors" ; "comment""Green" ""

let color_included_module = new O.string_cp ~group: Cam_rc.gui_ini
    ["modules_view" ; "colors" ; "included_module""Grey" ""

let open_source_command =  new O.string_cp ~group: Cam_rc.gui_ini
    ["modules_view" ; "open_source_command""chamo_open_file" ""

let f_open_file ?(char=0) file =
  let com = Printf.sprintf "%s %s %d"
      open_source_command#get
      (Filename.quote file)
      ((Cam_misc.line_of_char file char)+1)
  in
  Cam_commands.eval_command com

let dump_files = Hashtbl.create 13

let get_modules_from_dir dir =
  let dump_file = Filename.concat dir "dump.odoc" in
  try
    Hashtbl.find dump_files dump_file
  with
    Not_found ->
      try
        if not (Sys.file_exists dump_file) then
          failwith ("no file "^dump_file)
        else
          let l = Odoc_info.load_modules dump_file in
          Hashtbl.replace dump_files dump_file l;
          l
      with
        Failure s ->
          prerr_endline s;
          prerr_endline ("no module information in "^dir);
          []

type row_content =
    ME of module_element
  | CE of class_element

let location_of_module_element = function
  | Element_module m -> Some m.m_loc
  | Element_module_type m -> Some m.mt_loc
  | Element_class c -> Some c.cl_loc
  | Element_class_type c -> Some c.clt_loc
  | Element_value v -> Some v.val_loc
  | Element_type t -> Some t.ty_loc
  | Element_exception e -> Some e.ex_loc
  | Element_module_comment _ -> None
  | Element_included_module _ -> None

let location_of_class_element = function
  | Class_attribute a -> Some a.att_value.val_loc
  | Class_method m -> Some m.met_value.val_loc
  | Class_comment _ -> None

let location_of_ele = function
    ME e -> location_of_module_element e
  | CE e -> location_of_class_element e

class box dir =
  let vbox = GPack.vbox () in
  let wscroll = GBin.scrolled_window
      ~vpolicy: `AUTOMATIC
      ~hpolicy: `AUTOMATIC
      ~packing: (vbox#pack ~expand: true)
      ()
  in
  let cols = new GTree.column_list in
  let col_display = cols#add Gobject.Data.string in
  let col_type = cols#add Gobject.Data.string in
  let (col_data: row_content GTree.column) = cols#add Gobject.Data.caml in

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

  let () =
    let col = GTree.view_column ()
        ~renderer:(renderer, ["text", col_type]) in
    ignore (view#append_column col)
  in

  object(self)
    val mutable selection = (None : row_content option)

    method on_select _ = ()
    method on_unselect _ = ()
(*
    method expand _ = false
*)

    method menu_ctx = function
        None -> []
      |        Some ele ->
          match location_of_ele ele with
            None -> []
          | Some loc ->
              (match loc.Odoc_info.loc_impl with
                None -> []
              |        Some (file,char) ->
                  [`I ("Implementation",
                       fun () -> f_open_file ~char file)]
              ) @
              (match loc.Odoc_info.loc_inter with
                None -> []
              |        Some (file,char) ->
                  [`I ("Interface",
                       fun () -> f_open_file ~char file)]
              )

    method color_of_element = function
      |        ME (Element_module _) -> color_module#get
      |        ME (Element_module_type _) -> color_module_type#get
      |        ME (Element_included_module _) -> color_included_module#get
      |        ME (Element_value _) -> color_value#get
      |        ME (Element_type _) -> color_type#get
      |        ME (Element_exception _) -> color_exception#get
      |        ME (Element_module_comment _) -> color_comment#get
      |        ME (Element_class _) -> color_class#get
      |        ME (Element_class_type _) -> color_class_type#get
      |        CE (Class_attribute _) -> color_value#get
      |        CE (Class_method _) -> color_value#get
      |        CE (Class_comment _) -> color_comment#get

    method init_col_display :
        col_display:GTree.view_column ->
          complete:row_content GTree.column ->
            renderer:GTree.cell_renderer_text -> GTree.tree_store -> unit =
      fun ~col_display ~complete ~renderer _ ->
      let f (store:GTree.model) (iter:Gtk.tree_iter) =
        let props =
          let ele = store#get ~row: iter ~column: complete in
          [`FOREGROUND (self#color_of_element ele)]
        in
        renderer#set_properties props
      in
      ignore (col_display#set_cell_data_func renderer f)

    method on_collapse _ = ()
    method on_expand _ = ()
    method selection = selection

    method box = vbox

    method select ele =
      selection <- Some ele ;
      self#on_select ele

    method unselect ele =
      selection <- None ;
      self#on_unselect ele
    method col_display = col_display
    method col_data = col_data
    method view = view

    method display_string_of_ele = function
        ME (Element_module m) ->
          Printf.sprintf "module %s" (N.simple m.m_name)
      |        ME (Element_module_type m) ->
          Printf.sprintf "module type %s" (N.simple m.mt_name)
      |        ME (Element_included_module m) ->
          "<include>"
      |        ME (Element_class c) ->
          Printf.sprintf "class %s" (N.simple c.cl_name)
      |        ME (Element_class_type c) ->
          Printf.sprintf "class type %s" (N.simple c.clt_name)
      |        ME (Element_value v) ->
          Printf.sprintf "val %s" (N.simple v.val_name)
      |        ME (Element_type t) ->
          Printf.sprintf "type %s" (N.simple t.ty_name)
      |        ME (Element_exception e) ->
          Printf.sprintf "exception %s" (N.simple e.ex_name)
      |        ME (Element_module_comment t) ->
          Odoc_info.string_of_text t
      |        CE (Class_attribute a) ->
          Printf.sprintf "val %s" (N.simple a.att_value.val_name)
      |        CE (Class_method m) ->
          Printf.sprintf "method %s" (N.simple m.met_value.val_name)
      |        CE (Class_comment t) ->
          Odoc_info.string_of_text t

    method subs_of_ele = function
        ME (Element_module m) ->
          List.map (fun e -> ME e) (module_elements m)
      |        ME (Element_module_type m) ->
          List.map (fun e -> ME e) (module_type_elements m)
      |        ME (Element_included_module _) ->
          []
      |        ME (Element_class c) ->
          List.map (fun e -> CE e) (class_elements c)
      |        ME (Element_class_type c) ->
          List.map (fun e -> CE e) (class_type_elements c)
      |        ME (Element_value _)
      |        ME (Element_type _)
      |        ME (Element_exception _)
      |        ME (Element_module_comment _)
      |        CE (Class_attribute _)
      |        CE (Class_method _)
      |        CE (Class_comment _) ->
          []

    method string_type_of_ele = function
        ME (Element_value v) ->
          Some (Odoc_info.string_of_type_expr v.val_type)
      |        CE (Class_attribute a) ->
          Some (Odoc_info.string_of_type_expr a.att_value.val_type)
      |        CE (Class_method m) ->
          Some (Odoc_info.string_of_type_expr m.met_value.val_type)
      |        _ ->
          None

    method insert_ele ?parent ele =
      let row = store#append ?parent () in
      store#set row col_data ele;
      store#set row col_display
        (to_utf8 (self#display_string_of_ele ele));
      begin
        match self#string_type_of_ele ele with
          None -> ()
        | Some s ->
             store#set row col_type (to_utf8 s);
      end;
      match self#subs_of_ele ele with
        [] -> ()
      |        l -> List.iter (self#insert_ele ~parent: row) l

    method update =
      (
       match selection with
         None -> ()
       | Some ele ->
           selection <- None ;
           self#unselect ele
      );
      store#clear ();
      let modules = get_modules_from_dir dir in
      List.iter (fun m -> self#insert_ele (ME (Element_module m))) modules


    initializer

      view#selection#set_mode `SINGLE;

      ignore
        (view#connect#row_expanded
           (fun it _ ->
             self#on_expand (store#get ~row: it ~column: col_data)
           )
        );
      ignore
        (view#connect#row_collapsed
           (fun it _ ->
             self#on_collapse (store#get ~row: it ~column: col_data)
           )
        );

      ignore
        (view#selection#connect#changed
           (fun () ->
             (
              match selection with
                None -> ()
              | Some ele -> self#unselect ele
             );
             let sel = view#selection in
             match sel#get_selected_rows with
               [] -> ()
             | row :: _ ->
                 let it = store#get_iter row in
                 self#select (store#get ~row: it ~column: col_data)
           )
        );

      (* connect the press on button 3 for contextual menu *)
      let _ = view#event#connect#button_press ~callback:
        (
         fun ev ->
           GdkEvent.Button.button ev = 3 &&
           GdkEvent.get_type ev = `BUTTON_PRESS &&
           (
            match self#menu_ctx self#selection with
              [] -> true
            | l ->
                GToolbox.popup_menu
                  ~button: 3
                  ~time: (Int32.of_int 0)
                  ~entries: l;
                true
           )
        )
      in
      self#init_col_display
        ~col_display: col ~complete: col_data ~renderer store;
      self#update
  end

class view
    (name : Cam_view.view_name)
    (dir : Cam_view.ressource_name)
    (box : box)
    (close_window_on_close : bool) =
  object (self)
    method changed = false
    method close : bool = close_window_on_close
    method name = name
    method refresh = box#update
    method ressource = dir
    method ressource_kind : Cam_view.ressource_kind = `Dir
  end

class factory : Cam_view.view_factory =
  object (self)
    method create res_name args =
      let box = new box res_name in
      let v = new view (self#name) res_name box true in
      let w = Cam_view.create_view_window
          ~title: (Printf.sprintf "%s [%s]" res_name self#name)
          v
      in
      let _ = w#vbox#pack ~expand: true box#box#coerce in
      (v, w#window)

    method create_no_window window res_name args =
      let box = new box res_name in
      let v = new view (self#name) res_name box false in
      (v, box#box#coerce)

    method known_ressource_kinds = [`Dir]
    method name = "modules"
  end

let _ = Cam_view.register_factory (new factory)


(*
class ele_list () =
  let hook_kind = ref (fun _ -> assert false) in
  let hook_name = ref (fun _ -> assert false) in
  let hook_desc = ref (fun _ -> assert false) in
  object(self)
    inherit [element] Gpattern.plist `SINGLE
        [
          (Some M.kind, Gpattern.String (fun ele -> !hook_kind ele)) ;
          (Some M.name, Gpattern.String (fun ele -> !hook_name ele)) ;
          (Some M.description, Gpattern.String (fun ele -> !hook_desc ele))
        ]
        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 string_kind_of_ele ele =
      let ((s,_,_),_) = self#content ele in
      s

    method string_name_of_ele ele =
      let ((_,s,_),_) = self#content ele in
      s

    method string_description_of_ele ele =
      let ((_,_,s),_) = self#content ele in
      s

    method content : element -> (string*string*string) * GDraw.optcolor option =
      fun ele ->
      match ele with
        ME me ->
          (
           match me with
           | Element_value v ->
               (
                (
                 "val",
                 N.simple v.val_name,
                 self#string_of_info_opt v.val_info
                ),
                Some (`NAME Cam_config.color_view_value#get)
               )
           | Element_exception e ->
               (
                ("exception",
                 N.simple e.ex_name,
                 self#string_of_info_opt e.ex_info
                ),
                Some (`NAME Cam_config.color_view_exception#get)
               )
           | Element_type t ->
               (
                ("type",
                 N.simple t.ty_name,
                 self#string_of_info_opt t.ty_info
                ),
                Some (`NAME Cam_config.color_view_type#get)
               )
           | _ -> assert false
          )
      | CE ce ->
          match ce with
          | Class_attribute a ->
              (
               ("val",
                N.simple a.att_value.val_name,
                self#string_of_info_opt a.att_value.val_info
               ),
               Some (`NAME Cam_config.color_view_value#get)
              )
          | Class_method m ->
              (
               ("method",
                N.simple m.met_value.val_name,
                self#string_of_info_opt m.met_value.val_info
               ),
               Some (`NAME Cam_config.color_view_value#get)
              )
          | _ -> 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
          | _ -> []

    initializer
      hook_kind := self#string_kind_of_ele;
      hook_name := self#string_name_of_ele;
      hook_desc := self#string_description_of_ele
  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 cols = new GTree.column_list in
  let col_display = cols#add Gobject.Data.string in
  let (col_data: Odoc_info.Module.module_element GTree.column) = cols#add Gobject.Data.caml in

  let store = GTree.tree_store cols 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 _ = wscroll#misc#set_size_request ~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 =
      store#clear ();
      list_ele#update_data []

(* A VOIR
    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: Int32.zero
                         ~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 parent ele =
      match ele with
        | Element_module m -> self#insert_module ~parent m
        | Element_module_type mt -> self#insert_module_type parent mt
        | Element_class c -> self#insert_class parent c
        | Element_class_type ct -> self#insert_class_type parent ct
        | _ -> ()

    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 selected_rr =
      match tv#selection#get_selected_rows with
      | [] -> None
      | path :: _ -> Some (store#get_row_reference path)

    method on_selection_changed () =
      match self#selected_rr with
        None -> list_ele#update_data []
      |        Some rr ->
          let row = rr#iter in
          let l_eles =
            match store#get ~row ~column: col_data with
              Element_class c ->
                self#separate_class_elements (class_elements c)
            | Element_class_type ct ->
                self#separate_class_elements (class_type_elements ct)
            | Element_module m ->
                snd (self#separate_module_elements (module_elements m))
            | Element_module_type mt ->
                snd (self#separate_module_elements (module_type_elements mt))
            | _ -> []
          in
          list_ele#update_data l_eles


    method insert_class parent (c : t_class) =
      let row = store#append ~parent: parent#iter () in
      store#set ~row ~column: col_display ("class "^(N.simple c.cl_name)) ;
      store#set ~row ~column: col_data (Element_class c)

    method insert_class_type parent (ct : t_class_type) =
      let row = store#append ~parent: parent#iter () in
      store#set ~row ~column: col_display ("class type "^(N.simple ct.clt_name));
      store#set ~row ~column: col_data (Element_class_type ct)

    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) ?parent (m : t_module) =
      let parent = match parent with None -> None | Some rr -> Some rr#iter in
      let row = store#append ?parent () in
      store#set ~row ~column: col_display ((if top then "" else "module ")^(N.simple m.m_name));
      store#set ~row ~column: col_data (Element_module m);

      let (l_subs, l_eles) = self#separate_module_elements (module_elements m) in
      match l_subs with
        [] -> ()
      |        _ -> List.iter (self#insert_module_ele (store#get_row_reference (store#get_path row))) l_subs


(* A VOIR: garder les noeud expandés
                         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 ()
*)

    method insert_module_type parent (mt : t_module_type) =
      let row = store#append ~parent: parent#iter () in
      store#set ~row ~column: col_display ("module type "^(N.simple mt.mt_name)) ;
      store#set ~row ~column: col_data (Element_module_type mt);
      let (l_subs, l_eles) = self#separate_module_elements (module_type_elements mt) in
      match l_subs with
        [] -> ()
      |        _ ->  List.iter (self#insert_module_ele (store#get_row_reference (store#get_path row))) l_subs

    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) 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 ) modules
             with
               Not_found ->
                 self#refresh ()
        )

    initializer
      ignore(wb_refresh#connect#clicked (self#refresh ~force: true));
      ignore(tv#selection#connect#changed self#on_selection_changed);
  end

*)