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

(* Documentation manipulation. *)

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

type element =
    E_Type of string (* absolute name *)
  | E_Class of string
  | E_Class_type of string
  | E_Exception of string
  | E_Module of string
  | E_Module_type of string
  | E_Value of string
  | E_Attribute of string
  | E_Method of string
  | E_Section of string

let max_menu_length = 10

let doc_modules = ref []

let get_n_first_ele max l =
  let rec iter n l = 
    if n < max then
      match l with
	[] ->
	  ([], [])
      | h :: q ->
	  let (l1, l2) = iter (n+1) q in
	  (h :: l1, l2)
    else
      ([], l)
  in
  iter 0 l
	      
(* Return a shortcut key for the given menu label, depending
   on the already used letters and the previous menu label. *)
let get_shortcut_key used_letters prev_label label =
  let prev_label = String.uppercase prev_label in
  let label = String.uppercase label in
  let len = String.length label in
  let rec first_differ n prev =
    let len_prev = String.length prev in
    if n >= len_prev then
      if n >= len then
	None
      else
	match label.[n] with
	  'A' .. 'Z' when not (List.mem label.[n] used_letters) ->
	    Some label.[n]
	| _ ->
	    first_differ (n+1) ""
    else
      if n >= len then
	None
      else
	if prev.[n] <> label.[n] then
	  match label.[n] with
	    'A' .. 'Z' when not (List.mem label.[n] used_letters) ->
	      Some label.[n]
	  | _ ->
	      first_differ (n+1) ""
	else
	  first_differ (n+1) prev
  in
  (* if the first letter is alerady used, then we take the first
     letter of label which differs from the prev_label, and which is
     not already used.*)
  if len <= 0 then
    raise (Invalid_argument "get_shortcut_key")
  else
    if List.mem label.[0] used_letters then
      first_differ 0 prev_label
    else
      Some label.[0]

let keysym_of_char c =
  match c with
  | 'A' -> GdkKeysyms._A
  | 'B' -> GdkKeysyms._B
  | 'C' -> GdkKeysyms._C
  | 'D' -> GdkKeysyms._D
  | 'E' -> GdkKeysyms._E
  | 'F' -> GdkKeysyms._F
  | 'G' -> GdkKeysyms._G
  | 'H' -> GdkKeysyms._H
  | 'I' -> GdkKeysyms._I
  | 'J' -> GdkKeysyms._J
  | 'K' -> GdkKeysyms._K
  | 'L' -> GdkKeysyms._L
  | 'M' -> GdkKeysyms._M
  | 'N' -> GdkKeysyms._N
  | 'O' -> GdkKeysyms._O
  | 'P' -> GdkKeysyms._P
  | 'Q' -> GdkKeysyms._Q
  | 'R' -> GdkKeysyms._R
  | 'S' -> GdkKeysyms._S
  | 'T' -> GdkKeysyms._T
  | 'U' -> GdkKeysyms._U
  | 'V' -> GdkKeysyms._V
  | 'W' -> GdkKeysyms._W
  | 'X' -> GdkKeysyms._X
  | 'Y' -> GdkKeysyms._Y
  | 'Z' -> GdkKeysyms._Z
  | _ ->  GdkKeysyms._0

let load_doc_files files =
  let loaded_modules =
    List.flatten 
      (List.map 
	 (fun f ->
	   try
	     !Cam_global.display_message (Cam_messages.loading_file f);
             let l = Odoc_info.load_modules f in
	     !Cam_global.display_message Cam_messages.mOk;
	     l
           with Failure s -> 
	     !Cam_global.display_message s;
	     prerr_endline (f^": "^s) ; 
	     []
	 )
	 files
      )
  in
  Odoc_info.analyse_files
    ~sort_modules: true
    ~init: loaded_modules 
    []

(* Fill the given menu with submenus to access documentation. *)
let rec update load_doc f_create f_search_exact f_search_regexp menu =
  (* empty the menu *)
  List.iter (fun item -> menu#remove item ; item#destroy ()) menu#children;

  try
    if load_doc then
      doc_modules := load_doc_files
	  (List.map (fun ds -> ds.Cam_types.ds_file) !!Cam_config.doc_sources);

    let len = List.length !doc_modules in
    let nb_levels = 
      let rec iter acc n =
	let new_acc = acc * max_menu_length in
	if new_acc >= len then n
	else iter new_acc (n+1)
      in
      iter 1 1
    in

    let nb_items_by_menu = (* nVx = x^(1/n) *)
      if nb_levels = 0 then
	float_of_int max_menu_length
      else
	let fnb_levels = float_of_int nb_levels in
	let n_racine = (float_of_int len) ** ( 1. /. fnb_levels) in
	ceil n_racine
    in
    
    let rec create_menu menu level mods =
      let len = List.length mods in
      if len <= (int_of_float nb_items_by_menu) then
	let _ = 
	  List.fold_left
	    (fun (previous, acc) -> fun m ->
	      let item = GMenu.menu_item ~label: m.Odoc_info.Module.m_name ~packing: menu#add () in
	      let f m = f_create (E_Module m.Odoc_info.Module.m_name) in
	      let _ = item#connect#activate (fun () -> f m) in
	      (m.Odoc_info.Module.m_name, acc)
	    )
	    ("", [])
	    mods
	in
	()
      else
	let rec iter l =
	  match l with
	    [] ->
	      ()
	  | _ ->
	      let n = int_of_float ((nb_items_by_menu) ** (float_of_int level)) in
	      let (first, remain) = get_n_first_ele n l in
	      let ele_1 = List.hd first in
	      let ele_last = List.hd (List.rev first) in
	      let item = GMenu.menu_item 
		  ~label: (ele_1.Odoc_info.Module.m_name^" .. "^ele_last.Odoc_info.Module.m_name)
		  ~packing: menu#add 
		  () 
	      in
	      let submenu = GMenu.menu () in
	      let _ = item#set_submenu submenu in
	      create_menu submenu (level - 1)first ;
	      iter remain
	in
	iter mods
    in
    create_menu menu (nb_levels - 1) !doc_modules ;
    
    
    (* add a separator *)
    let _ = GMenu.menu_item ~packing: menu#add () in
    
    (* add the items for research. *)
    let item_exact_search = 
      GMenu.menu_item ~label: Cam_messages.m_search_exact
	~packing: menu#add
	()
    in
    let _ = item_exact_search#connect#activate f_search_exact in
    let item_exact_regexp = 
      GMenu.menu_item ~label: Cam_messages.m_search_regexp
	~packing: menu#add
	()
    in
    let _ = item_exact_regexp#connect#activate f_search_regexp in
    
    (* add a separator *)
    let _ = GMenu.menu_item ~packing: menu#add () in

    (* add the items to regenerate some doc. *)
    List.iter 
      (fun ds ->
	match ds.Cam_types.ds_label_com with
	  None -> ()
	| Some (name, command) ->
	    let item = GMenu.menu_item 
		~label: name ~packing: menu#add ()
	    in
	    let f () =
	      !Cam_global.display_message (Cam_messages.running_com command);
	      let n = Sys.command command in
	      if n <> 0 then
		GToolbox.message_box Cam_messages.error 
		  (Cam_messages.error_exec command) ;
	      !Cam_global.display_message "";
	      update true f_create f_search_exact f_search_regexp menu
	    in
	    let _ = item#connect#activate f in
	    ()
      )
      !!Cam_config.doc_sources
  with
    Failure s ->
      GToolbox.message_box Cam_messages.error s;
      ()


let get_module name = 
  let l = Odoc_info.Search.search_by_name
      !doc_modules
      (Str.regexp ("^"^(Str.quote name)^"$"))
  in
  match 
    List.filter
      (fun e ->
	match e with
	  Odoc_info.Search.Res_module _ -> true
	| _ -> false)
      l
  with
    [Odoc_info.Search.Res_module m] -> Some m
  | [] -> 
(*      print_string ("module "^name^" not found"); print_newline () ;*)
      None
  | _ ->
(*      print_string ("module "^name^" found several times"); print_newline () ;*)
      None

let get_module_type name = 
  let l = Odoc_info.Search.search_by_name
      !doc_modules
      (Str.regexp ("^"^(Str.quote name)^"$"))
  in
  match 
    List.filter
      (fun e ->
	match e with
	  Odoc_info.Search.Res_module_type _ -> true
	| _ -> false)
      l
  with
    [Odoc_info.Search.Res_module_type m] -> Some m
  | [] -> 
(*      print_string ("module type "^name^" not found"); print_newline () ;*)
      None
  | _ ->
(*      print_string ("module type "^name^" found several times"); print_newline () ;*)
      None

let get_module_of_type name = 
  let father = Odoc_info.Name.father name in
  get_module father

let get_module_type_of_type name = 
  let father = Odoc_info.Name.father name in
  get_module_type father

let get_module_of_exception = get_module_of_type
let get_module_type_of_exception = get_module_type_of_type

let get_module_of_value = get_module_of_type
let get_module_type_of_value = get_module_type_of_type

let get_class name = 
  let l = 
    Odoc_info.Search.search_by_name
      !doc_modules
      (Str.regexp ("^"^(Str.quote name)^"$"))
  in
  match
    List.filter
      (fun e ->
	match e with
	  Odoc_info.Search.Res_class _ -> true
	| _ -> false)
      l
  with
    [Odoc_info.Search.Res_class c] -> Some c
  | [] -> 
(*      print_string ("class "^name^" not found"); print_newline () ;*)
      None
  | _ ->
(*      print_string ("class "^name^" found several times"); print_newline () ;*)
      None

let get_class_type name = 
  let l = Odoc_info.Search.search_by_name
      !doc_modules
      (Str.regexp ("^"^(Str.quote name)^"$"))
  in
  match
    List.filter
      (fun e ->
	match e with
	  Odoc_info.Search.Res_class_type _ -> true
	| _ -> false)
      l
  with
    [Odoc_info.Search.Res_class_type ct] -> Some ct
  | [] -> 
      print_string ("class type "^name^" not found"); print_newline () ;
      None
  | _ ->
      print_string ("class type "^name^" found several times"); print_newline () ;
      None

let get_class_of_attribute name =
  let father = Odoc_info.Name.father name in
  get_class father

let get_class_of_method = get_class_of_attribute

let get_class_type_of_attribute name =
  let father = Odoc_info.Name.father name in
  get_class_type father

let get_class_type_of_method = get_class_type_of_attribute

