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

(*                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_doc.ml 334 2006-10-06 07:34:42Z zoggy $ *)

(** Documentation manipulation. *)


module O = Config_file

type doc_source = {
    mutable ds_file : string ;
    mutable ds_label_com : (string * string) option ;
  }

let value_to_doc_source v =
  match v with
  | O.Raw.Tuple [O.Raw.String f ; O.Raw.String lab; O.Raw.String com ] ->
      (
       let l_opt =
         match (lab, com) with
           (""""-> None
         | _ -> Some (lab, com)
       in
       { ds_file = f ; ds_label_com = l_opt }
      )
  | _ ->
      prerr_endline "Doc_source.value_to_ds";
      raise Not_found

let doc_source_to_value ds =
  let (lab, com) =
    match ds.ds_label_com with
      None -> ("""")
    |   Some (l,c) -> (l,c)
  in
  O.Raw.Tuple [ O.Raw.String ds.ds_file ; O.Raw.String lab; O.Raw.String com ]

let doc_source_cp_wrapper =
  {
    O.to_raw = doc_source_to_value ;
    O.of_raw = value_to_doc_source ;
  }

let doc_sources = new O.list_cp doc_source_cp_wrapper
    ~group: Cam_rc.core_ini
    ["doc_files"]
    [ { ds_file = Filename.concat Cam_installation.lib_dir "stdlib.odoc";
        ds_label_com = None } ;
      { ds_file = Filename.concat Cam_installation.lib_dir "cameleon.odoc" ;
        ds_label_com = None } ;
    ]
    ""

let font_doc_code = new O.string_cp ~group: Cam_rc.gui_ini
    ["fonts" ; "doc" ;  "code" ] "fixed" ""

let font_doc_code_bold = new O.string_cp ~group: Cam_rc.gui_ini
    ["fonts" ; "doc" ; "bold_code" ]
    "-misc-fixed-bold-r-normal--13-100-100-100-c-70-iso8859-1"
    ""

let font_doc_bold = new O.string_cp ~group: Cam_rc.gui_ini
    ["fonts" ; "doc" ; "bold" ] "7x13bold" ""

let font_doc_normal = new O.string_cp ~group: Cam_rc.gui_ini
    ["fonts" ; "doc" ; "normal" ]
    "-adobe-times-medium-r-normal-*-*-140-*-*-p-*-iso8859-1"
    ""

let color_doc_type = new O.string_cp ~group: Cam_rc.gui_ini
    ["colors" ; "doc" ; "type"]
    "Brown" ""

let color_doc_keyword = new O.string_cp ~group: Cam_rc.gui_ini
    ["colors" ; "doc" ; "keyword""Red" ""

let color_doc_constructor = new O.string_cp ~group: Cam_rc.gui_ini
    ["colors" ; "doc" ; "constructor""SlateBlue" ""

let color_doc_code = new O.string_cp ~group: Cam_rc.gui_ini
    ["colors" ; "doc" ; "code""Orange" ""

let doc_bookmarks = new O.list_cp O.string_wrappers
    ~group: Cam_rc.gui_ini
    ["bookmarks" ; "doc"]
    []
    ""

(** Add a doc bookmark to the list of bookmarks. *)

let add_doc_bookmark s =
  let l = Cam_misc.list_remove_doubles (doc_bookmarks#get @ [s]) in
  doc_bookmarks#set l;
  Cam_rc.save_gui ()

(* commands *)

let com_next_element = "next_element"
let com_prev_element = "previous_element"
let com_follow_link = "follow_link"
let com_follow_link_in_new = "follow_link_in_new"
let com_close = "close"
let com_search = "search"
let com_search_backward = "search_back"
let com_back = "back"
let com_add_bookmark = "add_bookmark"
let com_home = "home"
let com_end = "end"
let com_menu = "menu"

let doc_browser_actions = [
  com_next_element ; com_prev_element ;
  com_follow_link_in_new ; com_follow_link ;
  com_close ; com_search ; com_search_backward ;
  com_back ; com_add_bookmark ; com_home ; com_end ;
  com_menu ;
]

let default_doc_keymaps =
  [
    "C-n", com_next_element ;
    "C-p", com_prev_element ;
    "Return", com_follow_link ;
    "C-Return", com_follow_link_in_new ;
    "C-c", com_close ;
    "C-s", com_search ;
    "C-r", com_search_backward ;
    "C-BackSpace", com_back ;
    "C-a", com_add_bookmark ;
    "C-Home", com_home ;
    "C-End", com_end ;
    "C-m", com_menu ;
  ]

let keymap_doc = new O.list_cp
    (O.tuple2_wrappers Configwin.key_cp_wrapper O.string_wrappers)
    ~group: Cam_rc.gui_ini
    ["keymaps""doc"]
    []
    "Doc browser key bindings"

let init_keymaps () =
  match keymap_doc#get with
    [] ->
      List.iter
        (fun (k,a) -> Cam_rc.add_binding keymap_doc k a)
        default_doc_keymaps
  | _ ->
      ()


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 default_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 load_doc_files files =
  let loaded_modules =
    List.flatten
      (List.map
         (fun f ->
           try
             Cam_hooks.display_message (Cam_messages.loading_file f);
             let l = Odoc_info.load_modules f in
             Cam_hooks.display_message Cam_messages.ok;
             l
           with Failure s ->
             Cam_hooks.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 ~reload doc_modules 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 reload then
      doc_modules := load_doc_files
          (List.map (fun ds -> ds.ds_file) doc_sources#get);

    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 doc_modules (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.search_exact
        ~packing: menu#add
        ()
    in
    let _ = item_exact_search#connect#activate
        (fun () -> f_search_exact doc_modules)
    in
    let item_exact_regexp =
      GMenu.menu_item ~label: Cam_messages.search_regexp
        ~packing: menu#add
        ()
    in
    let _ = item_exact_regexp#connect#activate
        (fun () -> f_search_regexp doc_modules)
    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.ds_label_com with
          None -> ()
        | Some (name, command) ->
            let item = GMenu.menu_item
                ~label: name ~packing: menu#add ()
            in
            let f () =
              Cam_hooks.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_hooks.display_message "";
              update ~reload: true doc_modules f_create f_search_exact f_search_regexp menu
            in
            let _ = item#connect#activate f in
            ()
      )
      doc_sources#get
  with
    Failure s ->
      GToolbox.message_box Cam_messages.error s;
      ()


let get_module doc_modules 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 doc_modules 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 doc_modules name =
  let father = Odoc_info.Name.father name in
  get_module doc_modules father

let get_module_type_of_type doc_modules name =
  let father = Odoc_info.Name.father name in
  get_module_type doc_modules 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 doc_modules 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 doc_modules 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 doc_modules name =
  let father = Odoc_info.Name.father name in
  get_class doc_modules father

let get_class_of_method = get_class_of_attribute

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

let get_class_type_of_method = get_class_type_of_attribute

(**

Configuring doc sources

*)


module C = Configwin

let params_for_doc_source ds =
  let remove_column s = Str.global_replace (Str.regexp "::""  " s in
  let param_file = C.filename
      ~f:(fun s -> ds.ds_file <- remove_column s)
      Cam_messages.file ds.ds_file
  in
  let param_label = C.string
      ~f: (fun s ->
             let new_v =
               match ds.ds_label_com with
                 None -> Some (s, "")
               | Some (_, c) -> Some (s, c)
             in
             ds.ds_label_com <- new_v
          )
      Cam_messages.label
      (match ds.ds_label_com with None -> "" | Some (l,_) -> l)
  in
  let param_command = C.string
      ~f: (fun s ->
             let new_v =
               match ds.ds_label_com with
                 None -> Some ("", s)
               | Some (l, _) -> Some (l, s)
             in
             ds.ds_label_com <- new_v
          )
      Cam_messages.command
      (match ds.ds_label_com with None -> "" | Some (_, c) -> c)
  in

  [ param_file ; param_label ; param_command ]

(** Doc sources configuration box. *)

let config_doc_sources ~f_update_menu =
  let f_edit ds =
    ignore (C.simple_get Cam_messages.doc_file (params_for_doc_source ds)) ;
    ds
  in
  let f_add () =
    let ds = {
      ds_file = "" ;
      ds_label_com = None
    }
    in
    match C.simple_get Cam_messages.add
        (params_for_doc_source ds)
    with
      C.Return_cancel -> []
    | C.Return_apply
    | C.Return_ok -> [ds]
  in
  let p =
    C.list
      ~f: (fun l -> doc_sources#set l; Cam_rc.save_core (); f_update_menu ())
      ~eq: (fun ds1 ds2 -> ds1.ds_file = ds2.ds_file)
      ~edit: f_edit
      ~add: f_add
      ~titles: [ Cam_messages.file ;
                 Cam_messages.label ;
                 Cam_messages.command
               ]
      Cam_messages.doc_files
      (fun ds ->
        (ds.ds_file ::
         (match ds.ds_label_com with
           None -> [ "" ; "" ]
         | Some (l, c) -> [ l ; c ]
         )
        )
      )
      doc_sources#get
  in
  ignore (C.simple_get Cam_messages.configure_doc_sources [p])

(**

Configuring docbrowser shortcuts

*)


let configure_docbrowser_keymaps =
  Cam_keymaps.configure_keymaps
    Cam_messages.docbrowser_keyboard_shortcuts
    keymap_doc
    false
    doc_browser_actions
    Cam_rc.save_gui

let _ = Cam_commands.register
    { Cam_commands.com_name = Cam_constant.com_configure_docbrowser_keyboard_shortcuts ;
      Cam_commands.com_args = [| |] ;
      Cam_commands.com_more_args = None ;
      Cam_commands.com_f = (fun _ -> configure_docbrowser_keymaps ());
    }