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"]
[]
""
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 ()
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
| 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
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 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
[]
let rec update ~reload doc_modules f_create f_search_exact f_search_regexp 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 =
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 ;
let _ = GMenu.menu_item ~packing: menu#add () in
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
let _ = GMenu.menu_item ~packing: menu#add () in
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
| [] ->
None
| _ ->
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
| [] ->
None
| _ ->
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
| [] ->
None
| _ ->
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
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 ]
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])
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 ());
}