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

(** Gui for doc searching and browsing. *)

open Odoc_info 
open Parameter
open Value
open Type
open Exception
open Class 
open Module

open Cam_doc

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

let prerr_modifier_list l =
  List.iter
    (fun m -> 
      prerr_endline
      (match m with
	`SHIFT -> "`SHIFT"
      |	`LOCK -> "`LOCK"
      |	`CONTROL -> "`CONTROL"
      |	`MOD1 -> "`MOD1"
      |	`MOD2 -> "`MOD2"
      |	`MOD3 -> "`MOD3"
      |	`MOD4 -> "`MOD4"
      |	`MOD5 -> "`MOD5"
      |	`BUTTON1 -> "`BUTTON1"
      |	`BUTTON2 -> "`BUTTON2"
      |	`BUTTON3 -> "`BUTTON3"
      |	`BUTTON4 -> "`BUTTON4"
      |	`BUTTON5 -> "`BUTTON5"
      )
    )
    l

type link_kind =
    LinkLink of Cam_doc.element
  | LinkCode of Odoc_info.location

(** This function is initiliazed at the end of this module. 
   Is can be used to search and display one or more elements from their exact names.*)
let f_search_exact = ref (fun (_ : string) -> ())

(** This function initialized at the end of this module
   must be called when bookmarks have been updated. *)
let f_update_bookmarks = ref (fun () -> ())

class text_doc =
  let last_search = ref "" in
  fun () ->

  let window = GWindow.window ~kind: `DIALOG 
      ~width: 500 ~height: 600 ()
  in

  let vbox = GPack.vbox ~packing: window#add () in
  let wb_back = GButton.button 
      ~label: Cam_messages.back 
      ~packing: (vbox#pack ~expand: false)
      ()
  in
  let wscroll = GBin.scrolled_window ~packing: (vbox#pack ~expand: true) () in
  let wt = GEdit.text ~editable: false ~packing: wscroll#add () in

  let hbox_search = GPack.hbox ~packing: (vbox#pack ~expand: false) () in
  let wl_search = GMisc.label ~text: Cam_messages.search 
      ~packing: (hbox_search#pack ~expand: false)
      ()
  in
  let we_search = GEdit.entry
      ~editable: true
      ~packing: (hbox_search#pack ~expand: true) () 
  in

  let fixed_font = Gdk.Font.load !!Cam_config.font_doc_code in
  let fixed_bold_font = Gdk.Font.load !!Cam_config.font_doc_code_bold in
  let bold_font = Gdk.Font.load !!Cam_config.font_doc_bold in
  let normal_font = Gdk.Font.load !!Cam_config.font_doc_normal in
  let style = wt#misc#style#copy in
  let _ = style#set_font normal_font in
  let _ = wt#misc#set_style style in

  object (self)
    val mutable stack = Stack.create ()

    (** positions of elements *)
    val mutable elements = ([] : (element * int) list)

    (** elements by position. ((pos start, pos end), link) 
       They are ordered with the smallest position first.
    *)
    val mutable links = ([] : ((int * int) * (link_kind list)) list) 

    (** Color to print types, but not in a whole code block. *)
    method type_color = !!Cam_config.color_doc_type

    (** Color to print keywords, but not in a whole code block. *)
    method keyword_color = !!Cam_config.color_doc_keyword

    (** Color to print constructors, but not in a whole code block. *)
    method constructor_color = !!Cam_config.color_doc_constructor

    (** Color to print code. *)
    method code_color = !!Cam_config.color_doc_code

    method box = vbox
    method window = window
    method pop = 
      try
	let ele = Stack.pop stack in
	try
	  let ele2 = Stack.top stack in
	  self#display ele2
	with 
	  _ -> self#push ele
      with
	_ -> ()

    method push ele = 
      try
	self#display ele ;
	Stack.push ele stack
      with
	Failure s ->
	  GToolbox.message_box Cam_messages.error s

    method current_ele = 
      try Some (Stack.top stack)
      with _ -> None

    method add_current_to_doc_bookmarks =
      match self#current_ele with
	None -> ()
      |	Some e -> 
	  Cam_config.add_doc_bookmark (self#name_of_ele e) ;
	  !f_update_bookmarks ()

    method name_of_ele ele =
      match ele with
	E_Module name
      |	E_Module_type name
      |	E_Class name
      |	E_Class_type name
      |	E_Type name
      |	E_Value name
      |	E_Exception name
      |	E_Attribute name
      |	E_Method name
      |	E_Section name -> name

    method display ele =
      match ele with
	E_Module name ->
	  (
	   match Cam_doc.get_module name with
	     None ->
	       raise (Failure (Cam_messages.error_not_found_module name))
	   | Some m -> 
	       self#display_module m ;
	       window#set_title name
	  )
      |	E_Module_type name ->
	  (
	   match Cam_doc.get_module_type name with
	     None ->
	       raise (Failure (Cam_messages.error_not_found_module_type name))
	   | Some m -> 
	       self#display_module_type m ;
	       window#set_title name
	  )
      |	E_Class name ->
	  (
	   match Cam_doc.get_class name with
	     None ->
	       raise (Failure (Cam_messages.error_not_found_class name))
	   | Some c -> 
	       self#display_class c ;
	       window#set_title name
	  )
      |	E_Class_type name ->
	  (
	   match Cam_doc.get_class_type name with
	     None ->
	       raise (Failure (Cam_messages.error_not_found_class_type name))
	   | Some ct -> 
	       self#display_class_type ct ;
	       window#set_title name
	  )
      |	E_Type name ->
	  (
	   match Cam_doc.get_module_of_type name with
	     None -> 
	       (
		match Cam_doc.get_module_type_of_type name with
		  None ->
		    raise (Failure (Cam_messages.error_not_found_mmt name))
		| Some mt ->
		    self#display_module_type mt ;
		    window#set_title mt.mt_name ;
		    try 
		      let pos = List.assoc ele elements in
		      self#goto pos (Name.simple name)
		    with
		      Not_found ->
			()
	       )
	   | Some m -> 
	       self#display_module m ;
	       window#set_title m.m_name ;
	       try 
		 let pos = List.assoc ele elements in
		 self#goto pos (Name.simple name)
	       with
		 Not_found ->
		   ()
	  )
      |	E_Value name ->
	  (
	   match Cam_doc.get_module_of_value name with
	     None ->
	       (
		match Cam_doc.get_module_type_of_value name with
		  None ->
		    raise (Failure (Cam_messages.error_not_found_mmt name))
		| Some mt ->
		    self#display_module_type mt ;
		    window#set_title mt.mt_name ;
		    try 
		      let pos = List.assoc ele elements in
		      self#goto pos (Name.simple name)
		    with
		      Not_found ->
			()
	       )
	   | Some m -> 
	       self#display_module m ;
	       window#set_title m.m_name ;
	       try 
		 let pos = List.assoc ele elements in
		 self#goto pos (Name.simple name)
	       with
		 Not_found ->
		   ()
	  )
      |	E_Exception name ->
	  (
	   match Cam_doc.get_module_of_exception name with
	     None ->
	       (
		match Cam_doc.get_module_type_of_exception name with
		  None ->
		    raise (Failure (Cam_messages.error_not_found_mmt name))
		| Some mt ->
		    self#display_module_type mt ;
		    window#set_title mt.mt_name ;
		    try 
		      let pos = List.assoc ele elements in
		      self#goto pos (Name.simple name)
		    with
		      Not_found ->
			()
	       )
	   | Some m -> 
	       self#display_module m ;
	       window#set_title m.m_name ;
	       try 
		 let pos = List.assoc ele elements in
		 self#goto pos (Name.simple name)
	       with
		 Not_found ->
		   ()
	  )
      |	E_Attribute name ->
	  (
	   match Cam_doc.get_class_of_attribute name with
	     None ->
	       (
		match Cam_doc.get_class_type_of_attribute name with
		  None ->
		    raise (Failure (Cam_messages.error_not_found_cct name))
		| Some ct ->
		    self#display_class_type ct ;
		    window#set_title ct.clt_name ;
		    try 
		      let pos = List.assoc ele elements in
		      self#goto pos (Name.simple name)
		    with
		      Not_found ->
			()
	       )
	   | Some c -> 
	       self#display_class c ;
	       window#set_title c.cl_name ;
	       try 
		 let pos = List.assoc ele elements in
		 self#goto pos (Name.simple name)
	       with
		 Not_found ->
		   ()
	  )
      |	E_Method name ->
	  (
	   match Cam_doc.get_class_of_method name with
	     None ->
	       (
		match Cam_doc.get_class_type_of_method name with
		  None ->
		    raise (Failure (Cam_messages.error_not_found_cct name))
		| Some ct ->
		    self#display_class_type ct ;
		    window#set_title ct.clt_name ;
		    try 
		      let pos = List.assoc ele elements in
		      self#goto pos (Name.simple name)
		    with
		      Not_found ->
			()
	       )
	   | Some c -> 
	       self#display_class c ;
	       window#set_title c.cl_name ;
	       try 
		 let pos = List.assoc ele elements in
		 self#goto pos (Name.simple name)
	       with
		 Not_found ->
		   ()
	  )

      |	E_Section name ->
	    let pere = Odoc_info.Name.father name in
	    match pere with
	      "" -> ()
	    | _ -> 
		match pere.[0] with
		  'A'..'M' ->
		    (
		     match get_module pere with
		       None ->
			 (
			  match get_module_type pere with
			    None ->
			      raise (Failure (Cam_messages.error_not_found_mmt pere))
			  | Some mt -> 
			      (
			       self#display_module_type mt ;
			       window#set_title mt.mt_name ;
			       try 
				 let pos = self#get_section_pos name in
				 self#goto pos (Name.simple name)
			       with
				 Not_found ->
				   ()
			      )
			 )
		     | Some m ->
			 (
			  self#display_module m ;
			  window#set_title m.m_name ;
			  try 
			    let pos = self#get_section_pos name in
			    self#goto pos (Name.simple name)
			  with
			    Not_found -> ()
			 )
		    )

		| _ ->
		    (
		     match get_class pere with
		       None ->
			 (
			  match get_class_type pere with
			    None ->
			      raise (Failure (Cam_messages.error_not_found_cct pere))
			  | Some ct -> 
			      (
			       self#display_class_type ct ;
			       window#set_title ct.clt_name ;
			       try 
				 let pos = self#get_section_pos name in
				 self#goto pos (Name.simple name)
			       with
				 Not_found ->
				   ()
			      )
			 )
		     | Some c ->
			 (
			  self#display_class c ;
			  window#set_title c.cl_name ;
			  try 
			    let pos = self#get_section_pos name in
			    self#goto pos (Name.simple name)
			  with
			    Not_found ->
			      ()
			 )
		    )
	  
	  
    method goto pos s =
      self#goto2 pos (String.length s)

    method goto2 pos len =
      wt#set_position pos ;
      wt#select_region pos (pos + len)

    method clear =
      wt#delete_text 0 wt#length ;
      links <- [] ;
      elements <- []

    method add_element start element = elements <- (element, start) :: elements

    method add_link start len link_kinds = links <- links @ [(start, start + len), link_kinds]

    method links_by_pos pos =
      try
	snd
	  (List.find 
	     (fun ((st, en), link_kinds) -> st <= pos && pos <= en)
	     links
	  )
      with
	Not_found -> []

    (** Get the position of the given section name, fom the list of elements. 
    @raise Not_found if the section name was not found.*)
    method get_section_pos name =
      let simple = Name.simple name in
      snd (List.find 
	     (fun (e, _) -> e = E_Section simple)
	     elements)
	     

    (** Display a keyword. *)
    method put_keyword s = wt#insert 
	~font: fixed_font
	~foreground: (`NAME self#keyword_color) 
	s

    (** Display a constructor. *)
    method put_constructor s = wt#insert
	~font: fixed_font
	~foreground: (`NAME self#constructor_color) 
	s

    (** Display a string containing some [type_expr] and add links
       to the definition of these types. *)
    method put_string_type_expr m_name s =
      let s_re = "\\([A-Z]\\([a-zA-Z_\'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_\'0-9]*\\)" in
      let re = Str.regexp s_re in
      let rec f str =
	let pos_opt = 
	  try Some (Str.search_forward re str 0)
	  with Not_found -> 
	    None
	in
	match pos_opt with
	  None ->
	    wt#insert ~font: fixed_font ~foreground: (`NAME self#type_color) str
	| Some pos ->
	    let match_s = Str.matched_string str in
	    let len = String.length match_s in
	    let before = String.sub str 0 pos in
	    let after = String.sub str (pos + len) ((String.length str) - pos - len) in
	    wt#insert ~font: fixed_font ~foreground: (`NAME self#type_color) before ;
	    let rel = Name.get_relative m_name match_s in
	    self#add_link wt#length (String.length rel) [ LinkLink (E_Type match_s)] ;
	    wt#insert ~font: fixed_font ~foreground: (`NAME self#type_color) rel;
	    f after
      in
      f s

    (** Display a string containing some module types and add links
       to the definition of these types. *)
    method put_string_module_type_expr m_name s =
      let s_re = "\\([A-Z]\\([a-zA-Z_\'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_\'0-9]*\\)" in
      let re = Str.regexp s_re in
      let rec f str =
	let pos_opt = 
	  try Some (Str.search_forward re str 0)
	  with Not_found -> 
	    None
	in
	match pos_opt with
	  None ->
	    wt#insert ~font: fixed_font ~foreground: (`NAME self#type_color) str
	| Some pos ->
	    let match_s = Str.matched_string str in
	    let len = String.length match_s in
	    let before = String.sub str 0 pos in
	    let after = String.sub str (pos + len) ((String.length str) - pos - len) in
	    wt#insert ~font: fixed_font ~foreground: (`NAME self#type_color) before ;
	    let rel = Name.get_relative m_name match_s in
	    self#add_link wt#length (String.length rel) [LinkLink (E_Module_type match_s)] ;
	    wt#insert ~font: fixed_font ~foreground: (`NAME self#type_color) rel;
	    f after
      in
      f s

    (** Display a [Types.type_expr].*)
    method put_type_expr m_name t =
      let s = String.concat "\n"
	  (Str.split (Str.regexp "\n") (Odoc_info.string_of_type_expr t))
      in
      let s2 = Str.global_replace (Str.regexp "\n") "\n       " s in
      self#put_string_type_expr m_name s2

    (** Display a [Types.class_type].*)
    method put_class_type_expr m_name t =
      let s = String.concat "\n"
	  (Str.split (Str.regexp "\n") (Odoc_info.string_of_class_type t))
      in
      let s2 = Str.global_replace (Str.regexp "\n") "\n       " s in
      self#put_string_type_expr m_name s2

    (** Display a [Types.type_expr list].*)
    method put_type_expr_list m_name sep l =
      let s = Odoc_info.string_of_type_list sep l in
      let s2 = Str.global_replace (Str.regexp "\n") "\n       " s in
      self#put_string_type_expr m_name s2

    (** Display a [Types.module_type]. *)
    method put_module_type m_name t =
      let s = String.concat "\n"
	  (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type t))
      in
      let s2 = Str.global_replace (Str.regexp "\n") "\n       " s in
      self#put_string_module_type_expr m_name s2

    (** Display OCaml code. *)
    method put_code ?(with_pre=false) code = 
      wt#insert ~font: fixed_font ~foreground: (`NAME self#code_color) code

    (** Display a text element. *)
    method put_text_ele bold fixed e =
      match e with
      |	Odoc_info.Raw s -> 
	  (
	   match bold, fixed with
	     true, true -> wt#insert ~font: fixed_bold_font s
	   | true, false -> wt#insert ~font: bold_font s
	   | false, true -> wt#insert ~font: fixed_font s
	   | false, false -> wt#insert s
	  )
      |	Odoc_info.Code s -> 
	  wt#insert
	    ~foreground: (`NAME self#code_color) 
	    ~font: (if bold then fixed_bold_font else fixed_font) 
	    s
      |	Odoc_info.CodePre s -> 
	  wt#insert
	    ~foreground: (`NAME self#code_color) 
	    ~font: fixed_font
	    ("\n"^s^"\n")
      |	Odoc_info.Verbatim s -> wt#insert s
      |	Odoc_info.Bold t -> self#put_text ~bold: true ~fixed t
      |	Odoc_info.Italic t -> self#put_text ~bold ~fixed t
      |	Odoc_info.Emphasize t -> self#put_text ~bold ~fixed t
      |	Odoc_info.Center t -> self#put_text ~bold ~fixed t
      |	Odoc_info.Left t ->  self#put_text ~bold ~fixed t
      |	Odoc_info.Right t -> self#put_text ~bold ~fixed t
      |	Odoc_info.List tl ->
	  List.iter 
	    (fun t -> self#put_text ~bold ~fixed ((Raw "\n  - ") ::  t)) 
	    tl;
	  wt#insert "\n"
      |	Odoc_info.Enum tl ->
	  List.iter 
	    (fun t -> self#put_text ~bold ~fixed ((Raw "\n  - ") ::  t)) 
	    tl;
	  wt#insert "\n"
      |	Odoc_info.Newline ->
	  wt#insert "\n"
      |	Odoc_info.Block t ->
	  wt#insert "\n";
	  self#put_text ~bold ~fixed t;
	  wt#insert "\n"
      |	Odoc_info.Title (n, label_opt, t) ->
	  wt#insert "\n";
	  (match label_opt with
	    None -> ()
	  | Some l -> self#add_element wt#length (E_Section l)
	  );
	  self#put_text ~bold: true ~fixed t;
	  wt#insert "\n"
      |	Odoc_info.Latex _ ->
	  (* don't care about LaTeX stuff in HTML. *)
	  ()
      |	Odoc_info.Link (s, t) ->
	  self#put_text ~bold ~fixed t
      |	Odoc_info.Ref (s, kind_opt) ->
	  (
	   match kind_opt with
	     None ->
	      wt#insert ~font: fixed_font s ;
	       ()
	   | Some kind ->
	       let ele = 
		match kind with
		  Odoc_info.RK_module -> E_Module s
		| Odoc_info.RK_module_type -> E_Module_type s
		| Odoc_info.RK_class -> E_Class s
		| Odoc_info.RK_class_type -> E_Class_type s
		| Odoc_info.RK_value -> E_Value s
		| Odoc_info.RK_type -> E_Type s
		| Odoc_info.RK_exception -> E_Exception s
		| Odoc_info.RK_attribute -> E_Attribute s
		| Odoc_info.RK_method -> E_Method s
		| Odoc_info.RK_section t -> E_Section s
	       in
	       self#add_link wt#length (String.length s) [ LinkLink ele ] ;
	       wt#insert ~font: fixed_bold_font s ;
	       ()
	  )
      |	Odoc_info.Superscript t ->
	  wt#insert "{^";
	  self#put_text ~bold ~fixed t;
	  wt#insert "}"
      |	Odoc_info.Subscript t ->
	  wt#insert "{_";
	  self#put_text ~bold ~fixed t;
	  wt#insert "}"

    (** Display a text. *)
    method put_text ?(bold=false) ?(fixed=false) t =
      List.iter (self#put_text_ele bold fixed) t

    (** Display an author list. *)
    method put_author_list l =
      match l with
	[] ->
	  ()
      | _ ->
	  wt#insert ~font: bold_font (Cam_messages.authors^": ") ;
	  wt#insert ((String.concat ", " l)^"\n")

    (** Display the given optional version information.*)
    method put_version_opt v_opt =
      match v_opt with
	None -> ()
      | Some v -> 
	  wt#insert ~font: bold_font (Cam_messages.version^": ") ;
	  wt#insert (v^"\n")

    (** Display the given optional since information.*)
    method put_since_opt s_opt =
      match s_opt with
	None -> ()
      | Some s -> 
	  wt#insert ~font: bold_font Cam_messages.since ;
	  wt#insert (" "^s^"\n")

    (** Display the given list of raised exceptions.*)
    method put_raised_exceptions l =
      match l with
	[] -> ()
      | (s, t) :: [] -> 
	  wt#insert ~font: bold_font Cam_messages.raises ;
	  wt#insert ~font: fixed_font (" "^s^" ") ;
	  self#put_text t; 
	  wt#insert "\n"
      | _ ->
	  wt#insert ~font: bold_font Cam_messages.raises ;
	  let f (ex, desc) =
	    wt#insert ~font: fixed_font ("\n  - "^ex^" ");
	    self#put_text desc;
	  in
	  List.iter f l;
	  wt#insert "\n"

    (** Display the given "see also" reference. *)
    method put_see (see_ref, t)  =
      let t_ref = 
	match see_ref with
	  Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ]
	| Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t
	| Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t
      in
      self#put_text t_ref

    (** Display the given list of "see also" references.*)
    method put_sees l =
      match l with
	[] -> ()
      | see :: [] -> 
	  wt#insert ~font: bold_font Cam_messages.see_also ;
	  self#put_see see ;
	  wt#insert "\n"
      | _ ->
	  wt#insert ~font: bold_font Cam_messages.see_also;
	  let f see = 
	    wt#insert ~font: fixed_font "\n  - " ;
	    self#put_see see
	  in
	  List.iter f l;
	  wt#insert "\n"

    (** Display the given optional return information.*)
    method put_return_opt return_opt =
      match return_opt with
	None -> ()
      | Some s -> 
	  wt#insert ~font: bold_font (Cam_messages.returns^" ");
	  self#put_text s ;
	  wt#insert "\n"

    (** Display a description, except for the [i_params] field. *)
    method put_info info_opt =
      match info_opt with
	None ->
	  wt#insert "\n"
      | Some info ->
	  let module M = Odoc_info in
	  (match info.M.i_deprecated with
	    None -> ()
	  | Some d -> 
	      wt#insert ~font: bold_font ~foreground: (`NAME "Red") Cam_messages.deprecated ;
	      self#put_text d);
	  (match info.M.i_desc with
	    None -> ()
	  | Some d when d = [Odoc_info.Raw ""] -> ()
	  | Some d -> self#put_text d ; wt#insert "\n" );

	  self#put_author_list info.M.i_authors ;
	  self#put_version_opt info.M.i_version ;
	  self#put_since_opt info.M.i_since ;
	  self#put_raised_exceptions info.M.i_raised_exceptions ;
	  self#put_return_opt info.M.i_return_value ;
	  self#put_sees info.M.i_sees ;
	  wt#insert "\n"

    (** Display the description of a parameter. *)
    method put_parameter_description p =
      match Parameter.names p with
	[] -> 
	  wt#insert "\n"
      | name :: [] ->
	  (
           (* Only one name, no need for label for the description. *)
	   match Parameter.desc_by_name p name with
	     None -> ()
	   | Some t -> self#put_text t ; 
	  );
	  wt#insert "\n"
      | l ->
          (*  A list of names, we display those with a description. *)
	  let l2 = List.filter (fun n -> (Parameter.desc_by_name p n) <> None) l in
	  match l2 with
	    [] -> wt#insert "\n"
	  | _ ->
	      List.iter
		(fun n ->
		  match Parameter.desc_by_name p n with
		    None -> ()
		  | Some t -> 
		      wt#insert ~font: fixed_bold_font ("  "^n);
		      self#put_text t;
		      wt#insert "\n"
		)
		l2
	  

    (** Display the list of described parameters, among the given list . *)
    method put_described_parameter_list father l =
      (* get the params which have a name, and at least one name described. *)
      let l2 = List.filter 
	  (fun p -> 
	    List.exists 
	      (fun n -> (Parameter.desc_by_name p n) <> None)
	      (Parameter.names p))
	  l
      in
      let f p = 
	self#put_code (Parameter.complete_name p) ;
	wt#insert " : " ;
	self#put_parameter_description p
      in
      match l2 with
	[] -> ()
      |	_ -> List.iter f l2 ; wt#insert "\n"

    (** Display a value. *)
    method put_value v =
      Odoc_info.reset_type_names ();
      self#put_keyword "val " ;
      self#add_element wt#length (E_Value v.val_name);
      let s = Name.simple v.val_name in
      self#add_link wt#length (String.length s) [ LinkCode v.val_loc ] ;
      wt#insert ~font: fixed_bold_font (s^" : ") ;
      self#put_type_expr (Name.father v.val_name) v.val_type ;
      wt#insert "\n" ;
      self#put_info v.val_info;
      self#put_described_parameter_list (Name.father v.val_name) v.val_parameters

    (** Display an exception. *)
    method put_exception e =
      Odoc_info.reset_type_names ();
      self#put_keyword "exception " ;
      self#add_element wt#length (E_Exception e.ex_name) ;
      let s = Name.simple e.ex_name in
      self#add_link wt#length (String.length s) [ LinkCode e.ex_loc ] ;
      wt#insert ~font: fixed_bold_font s ;
      (match e.ex_args with
	[] -> ()
      |	_ -> 
	  self#put_keyword " of " ;
	  self#put_type_expr_list (Name.father e.ex_name) " -> " e.ex_args
      ) ;
      (match e.ex_alias with
	None -> ()
      | Some ea -> 
	  wt#insert ~font: fixed_font " = " ;
	  (
	   match ea.ea_ex with
	     None -> wt#insert ~font: fixed_font ea.ea_name
	   | Some e -> 
	       let s = e.ex_name in
	       self#add_link wt#length (String.length s) 
		 [ LinkLink (E_Exception s) ; LinkCode e.ex_loc ] ;
	       wt#insert ~font: fixed_font e.ex_name
	  );
      );
      wt#insert "\n" ;
      self#put_info e.ex_info

    (** Display a type. *)
    method put_type t =
      Odoc_info.reset_type_names ();
      let father = Name.father t.ty_name in
      self#put_keyword "type ";
      (match t.ty_parameters with
	[] -> ()
      |	(tp, _, _) :: [] -> 
	  self#put_type_expr father tp ;  (* A VOIR: variance *)
	  wt#insert ~font: fixed_font " "
      |	l ->
	  self#put_type_expr_list father ", " 
	    (List.map (fun (t,_,_) -> t) l) ; (* A VOIR: variance *)
	  wt#insert ~font: fixed_font " "
      ) ;
      self#add_element wt#length (E_Type t.ty_name) ;
      let s = Name.simple t.ty_name in
      self#add_link wt#length (String.length s) [ LinkCode t.ty_loc ] ;
      wt#insert ~font: fixed_bold_font (s^" ") ;
      (match t.ty_manifest with 
	None -> ()
      | Some typ -> 
	  wt#insert ~font: fixed_font "= " ;
	  self#put_type_expr father typ ;
	  wt#insert ~font: fixed_font " " 
      );
      (match t.ty_kind with
	Type_abstract -> 
	  wt#insert "\n"
      |	Type_variant (l, pv) ->
	  wt#insert ~font: fixed_font ("= "^(if pv then "private" else "")^"\n") ;
	  let f constr =
	    self#put_keyword "   | " ;
	    self#put_constructor constr.vc_name ;
	    (match constr.vc_args with
	      [] -> ()
	    | l -> 
		self#put_keyword " of " ;
		self#put_type_expr_list father " * " l ;
	    ) ;
	    (match constr.vc_text with
	      None ->
		()
	    | Some t ->
		self#put_text ((Italic [ Raw "  (* " ]) :: t) ;
		self#put_text [Italic [ Raw " *)" ]] ;
	    );
	    wt#insert "\n"
	  in
	  List.iter f l

      |	Type_record (l, pv) ->
	  wt#insert ~font: fixed_font ("= "^(if pv then "private " else "")^"{\n");
	  let f r =
	    wt#insert ~font: fixed_font "   " ;
	    (if r.rf_mutable then self#put_keyword "mutable " else ()) ;
	    wt#insert ~font: fixed_font (r.rf_name^" : ") ;
	    self#put_type_expr father r.rf_type ;
	    wt#insert ~font: fixed_font ";" ;
	    (match r.rf_text with
	      None ->
		()
	    | Some t ->
		self#put_text ((Italic [ Raw "  (* " ]) :: t) ;
		self#put_text [Italic [ Raw " *)" ]] ;
	    ) ;
	    wt#insert "\n"
	  in
	  List.iter f l ;
	  wt#insert "}\n"
      ) ;
      self#put_info t.ty_info 


    (** Display a class attribute. *)
    method put_attribute a =
      self#put_keyword "val " ;
      (* html mark *)
      (if a.att_mutable then self#put_keyword "mutable " else ()) ;
      self#add_element wt#length (E_Attribute a.att_value.val_name) ;
      let s = Name.simple a.att_value.val_name in
      self#add_link wt#length (String.length s) [ LinkCode a.att_value.val_loc ] ;
      wt#insert ~font: fixed_bold_font (s^" : ") ;
      self#put_type_expr (Name.father a.att_value.val_name) a.att_value.val_type ;
      wt#insert "\n";
      self#put_info a.att_value.val_info

    (** Display a class method. *)
    method put_method m =
      self#put_keyword "method " ;
      (if m.met_private then self#put_keyword "private " else ()) ;
      (if m.met_virtual then self#put_keyword "virtual " else ()) ;
      self#add_element wt#length (E_Method m.met_value.val_name) ;
      let s = Name.simple m.met_value.val_name in
      self#add_link wt#length (String.length s) [ LinkCode m.met_value.val_loc ] ;
      wt#insert ~font: fixed_bold_font (s^" : ") ;
      self#put_type_expr (Name.father m.met_value.val_name) m.met_value.val_type ;
      wt#insert "\n";
      self#put_info m.met_value.val_info;
      self#put_described_parameter_list (Name.father m.met_value.val_name) m.met_value.val_parameters

    (** Display a list of parameters. *)
    method put_parameter_list m_name l =
      match l with
	[] ->
	  ()
      | _ ->
	  wt#insert ~font: bold_font (Cam_messages.parameters^":\n") ;
	  List.iter
	    (fun p ->
	      self#put_code (Parameter.complete_name p) ;
	      wt#insert " : " ;
	      self#put_type_expr m_name (Parameter.typ p) ;
	      wt#insert "\n" ;
	      self#put_parameter_description p ;
	    )
	    l

    (** Display a list of module parameters. *)
    method put_module_parameter_list m_name l =
      match l with
	[] ->
	  ()
      | _ ->
	  wt#insert ~font: bold_font (Cam_messages.parameters^": ") ;
	  let f (p, desc_opt) =
	    wt#insert ~font: fixed_font ("\n  - "^p.mp_name^" : ") ;
	    self#put_module_type m_name p.mp_type ;
	    (match desc_opt with
	      None -> ()
	    | Some t -> 
		wt#insert "\n" ;
		self#put_text t
	    );
	    wt#insert "\n"
	  in
	  List.iter f l

    (** Display a module. *)
    method put_module m =
      Odoc_info.reset_type_names ();
      self#put_keyword "module ";
      self#add_link wt#length (String.length m.m_name) 
	[LinkLink (E_Module m.m_name) ; LinkCode m.m_loc ];
      wt#insert ~font: fixed_bold_font 
	~foreground: (`NAME self#constructor_color) 
	m.m_name;
      wt#insert " : ";
      self#put_module_type (Name.father m.m_name) m.m_type ;
      wt#insert "\n" ;
      self#put_info m.m_info 

    (** Display a module type. *)
    method put_modtype ?(with_link=true) mt =
      Odoc_info.reset_type_names ();
      self#put_keyword "module type ";
      self#add_link wt#length (String.length mt.mt_name) 
	[LinkLink (E_Module_type mt.mt_name) ; LinkCode mt.mt_loc] ;
      wt#insert ~font: fixed_bold_font
	~foreground: (`NAME self#constructor_color) 
	mt.mt_name;
      (match mt.mt_type with
      |	Some t -> 
	  wt#insert " = "; 
	  self#put_module_type (Name.father mt.mt_name) t
      |	None -> ()
      );
      wt#insert "\n" ;
      self#put_info mt.mt_info 


    (** Display an included module. *)
    method put_included_module im =
      self#put_keyword "include " ;
      (
       match im.im_module with
	 None ->
	   wt#insert ~font: fixed_font im.im_name
       | Some mmt ->
	   match mmt with
	     Mod m -> 
	       let s = m.m_name in
	       self#add_link wt#length (String.length s) [ LinkLink (E_Module s)] ;
	       wt#insert ~font: fixed_font s
	   | Modtype mt ->
	       let s = mt.mt_name in
	       self#add_link wt#length (String.length s)  [LinkLink (E_Module_type s)] ;
	       wt#insert ~font: fixed_font s
      ) ;
      wt#insert "\n"

    (** Display a class. *)
    method put_class c =
      Odoc_info.reset_type_names ();
      self#put_keyword "class " ;
      (if c.cl_virtual then self#put_keyword "virtual " else ());
      (
       match c.cl_type_parameters with
	[] -> ()
      |	l -> wt#insert ~font: fixed_font ("["^(Odoc_info.string_of_type_list ", " l)^"] ")
      ) ;
      let s = Name.simple c.cl_name in
      self#add_link wt#length (String.length s) 
	[LinkLink (E_Class c.cl_name) ; LinkCode c.cl_loc] ;
      wt#insert ~font: fixed_bold_font s ;
      wt#insert " : ";
      self#put_class_type_expr (Name.father c.cl_name) c.cl_type;
      wt#insert "\n";
      self#put_info c.cl_info

    (** display a class type. *)
    method put_class_type ct =
      Odoc_info.reset_type_names ();
      self#put_keyword "class type " ;
      (if ct.clt_virtual then self#put_keyword "virtual " else ());
      (
       match ct.clt_type_parameters with
	[] -> ()
      |	l -> wt#insert ~font: fixed_font ("["^(Odoc_info.string_of_type_list ", " l)^"] ")
      ) ;
      let s = Name.simple ct.clt_name in
      self#add_link wt#length (String.length s) 
	[LinkLink (E_Class_type ct.clt_name) ; LinkCode ct.clt_loc] ;
      wt#insert ~font: fixed_bold_font s ;
      wt#insert " = ";
      self#put_class_type_expr (Name.father ct.clt_name) ct.clt_type;
      wt#insert "\n";
      self#put_info ct.clt_info

    (** Display a class comment.*)
    method put_class_comment text = self#put_module_comment text

    (** Display a module comment.*)
    method put_module_comment text = self#put_text (text @ [Newline ; Newline])

    (** Display the given list of inherited classes. *)
    method put_inheritance_info inher_l =
      let f tab inh =
	wt#insert ~font: fixed_font tab;
	(
	 match inh.ic_class with
	   None -> (* we can't make the link. *)
	     wt#insert ~font: fixed_bold_font (inh.ic_name^"  ") ;
	     (match inh.ic_text with
	       None -> ()
	     | Some t -> self#put_text t
	     )
	 | Some cct ->
	    (* we can create the link. *)
	     let real_name = (* even if it should be the same *)
	       match cct with
		 Cl c -> 
		  let s = c.cl_name in
		  self#add_link wt#length (String.length s) 
		    [LinkLink (E_Class s) ; LinkCode c.cl_loc] ;
		  s
	       | Cltype (ct, _) -> 
		   let s = ct.clt_name in
		   self#add_link wt#length (String.length s) 
		     [LinkLink (E_Class_type s) ; LinkCode ct.clt_loc] ;
		   s
	     in
	    wt#insert ~font: fixed_bold_font (real_name^"  ") ;
	     (match inh.ic_text with
	       None -> ()
	     | Some t -> self#put_text t
	     )
	);
	wt#insert "\n"
      in
      wt#insert ~font: bold_font (Cam_messages.inherits^"\n") ;
      List.iter (f "  ") inher_l ;
      wt#insert "\n"

    (** Display the inherited classes of the given class. *)
    method put_class_inheritance_info cl =
      let rec iter_kind k = 
	match k with
	  Class_structure ([], _) ->
	    ()
	| Class_structure (l, _) ->
	    self#put_inheritance_info l
	| Class_constraint (k, ct) ->
	    iter_kind k
	| Class_apply _
	| Class_constr _ ->
	    ()
      in
      iter_kind cl.cl_kind

    (** Display the inherited classes of the given class type. *)
    method put_class_type_inheritance_info clt =
      match clt.clt_kind with
	Class_signature ([], _) ->
	  ()
      |	Class_signature (l, _) ->
	  self#put_inheritance_info l
      |	Class_type _ ->
	  ()

    (** Display the given class.*)
    method display_class cl =
      wt#freeze ();
      self#clear;
      self#put_keyword "class ";
      (if cl.cl_virtual then self#put_keyword "virtual " else ()) ;
      self#add_link wt#length (String.length cl.cl_name) [ LinkCode cl.cl_loc ] ;
      self#put_constructor cl.cl_name;
      wt#insert " : ";
      self#put_class_type_expr (Name.father cl.cl_name) cl.cl_type ;
      wt#insert "\n" ;
      self#put_info cl.cl_info ;

      (* class inheritance *)
      self#put_class_inheritance_info cl;
      (* parameters *)
      self#put_parameter_list (Name.father cl.cl_name) cl.cl_parameters;

      (* the various elements *)
      List.iter 
	(fun element ->
	  match element with
	    Class_attribute a ->
	      self#put_attribute a
	  | Class_method m ->
	      self#put_method m
	  | Class_comment text ->
	      self#put_class_comment text
	)
	(Class.class_elements cl);

      wt#thaw ()
	
    (** Display the given class type.*)
    method display_class_type clt =
      wt#freeze ();
      self#clear;
      self#put_keyword "class type ";
      (if clt.clt_virtual then self#put_keyword "virtual " else ()) ;
      self#add_link wt#length (String.length clt.clt_name) [ LinkCode clt.clt_loc ] ;
      self#put_constructor clt.clt_name;
      wt#insert " = ";
      self#put_class_type_expr (Name.father clt.clt_name) clt.clt_type ;
      wt#insert "\n" ;
      self#put_info clt.clt_info ;

      (* class inheritance *)
      self#put_class_type_inheritance_info clt;

      (* the various elements *)
      List.iter 
	(fun element ->
	  match element with
	    Class_attribute a ->
	      self#put_attribute a
	  | Class_method m ->
	      self#put_method m
	  | Class_comment text ->
	      self#put_class_comment text
	)
	(Class.class_type_elements clt) ;

      wt#thaw ()


    (** Display the given module type.
       @raise Failure if an error occurs.*)
    method display_module_type mt =
      wt#freeze ();
      self#clear;
      self#put_keyword "module type ";
      self#add_link wt#length (String.length mt.mt_name) [ LinkCode mt.mt_loc ] ;
      self#put_constructor mt.mt_name;
      wt#insert "\n";
      (match mt.mt_type with
	None -> ()
      |	Some t -> 
	  wt#insert " = ";
	  self#put_module_type (Name.father mt.mt_name) t
      ) ;
      wt#insert "\n" ;
      self#put_info mt.mt_info ;
      
      (* parameters for functors *)
      self#put_module_parameter_list "" (Module.module_type_parameters mt);
      
      wt#insert "\n\n";

      (* module elements *)
      List.iter 
	(fun ele ->
	  match ele with
	    Element_module m ->
	      self#put_module m
	  | Element_module_type mt ->
	      self#put_modtype mt
	  | Element_included_module im ->
	      self#put_included_module im
	  | Element_class c ->
	      self#put_class c
	  | Element_class_type ct ->
	      self#put_class_type ct
	  | Element_value v ->
	      self#put_value v
	  | Element_exception e ->
	      self#put_exception e
	  | Element_type t ->
	      self#put_type t
	  | Element_module_comment text ->
	      self#put_module_comment text
	)
	(Module.module_type_elements mt);

      wt#thaw ()

    (** Display the given module. 
       @raise Failure if an error occurs.*)
    method display_module modu =
      wt#freeze ();
      self#clear;
      self#put_keyword "module ";
      self#add_link wt#length (String.length modu.m_name) [ LinkCode modu.m_loc ] ;
      self#put_constructor modu.m_name;
      wt#insert " : ";
      self#put_module_type (Name.father modu.m_name) modu.m_type ;
      wt#insert "\n" ;
      self#put_info modu.m_info ;
      
      (* parameters for functors *)
      self#put_module_parameter_list "" (Module.module_parameters modu) ;

      wt#insert "\n\n";

      (* module elements *)
      List.iter 
	(fun ele ->
	  match ele with
	    Element_module m ->
	      self#add_element wt#length (E_Module m.m_name) ;
	      self#put_module m
	  | Element_module_type mt ->
	      self#put_modtype mt
	  | Element_included_module im ->
	      self#put_included_module im
	  | Element_class c ->
	      self#put_class c
	  | Element_class_type ct ->
	      self#put_class_type ct
	  | Element_value v ->
	      self#put_value v
	  | Element_exception e ->
	      self#put_exception e
	  | Element_type t ->
	      self#put_type t
	  | Element_module_comment text ->
	      self#put_module_comment text
	)
	(Module.module_elements modu);
      
      wt#thaw ()

    (** @raise Not_found if no element is found. *)
    method get_next_element_from_pos p =
      let s, e = fst
	  (List.find 
	     (fun ((st, en), link_kinds) -> p < st)
	     links
	  )
      in
      (s, (e - s))

    (** @raise Not_found if no element is found. *)
    method get_previous_element_from_pos p =
      let s, e = fst
	  (List.find 
	     (fun ((st, en), link_kinds) -> p >= st)
	     (List.rev links)
	  )
      in
      (s, (e - s))

    method follow_link_by_pos p =
      match self#links_by_pos p with
      | (LinkLink ele) :: _ ->
	  self#push ele 
      | _ ->
	  ()

    method follow_link_by_pos_in_new p =
      match self#links_by_pos p with
      | (LinkLink ele) :: _ -> 
	  let text_doc = new text_doc () in 
	  text_doc#window#show () ;
	  text_doc#push ele
      | _ ->
	  ()

    method follow_current_position_link =
      let p = wt#position in
      self#follow_link_by_pos p

    method follow_current_position_link_in_new =
      let p = wt#position in
      self#follow_link_by_pos_in_new p

    method goto_next_element =
      let pos = wt#position in
      try
	let (pos, len) = self#get_next_element_from_pos pos in
	self#goto2 pos len;
      with
	Not_found ->
	  try 
	    let (pos, len) = self#get_next_element_from_pos (-1) in
	    self#goto2 pos len;
	  with Not_found -> 
	    ()

    method goto_previous_element =
      let pos = wt#position - 1 in
      try
	let (pos, len) = self#get_previous_element_from_pos pos in
	self#goto2 pos len;
      with
	Not_found ->
	  try 
	    let (pos, len) = self#get_previous_element_from_pos (wt#length - 1) in
	    self#goto2 pos len;
	  with Not_found -> 
	    ()

    method goto_next_string ?(force=false) s =
      last_search := s ;
      let p = wt#position + (if force then 1 else 0) in
      let l = wt#length in
      let t = wt#get_chars 0 l in
      try
	let i = Str.search_forward (Str.regexp_string s) t p in
	self#goto2 i (String.length s)
      with
	Not_found 
      |	Invalid_argument _ ->
	  try
	    let i = Str.search_forward (Str.regexp_string s) t 0 in
	    self#goto2 i (String.length s)
	  with
	    Not_found ->
	      ()

    method goto_previous_string s =
      last_search := s ;
      let p = wt#position - 1 in
      let l = wt#length in
      let t = wt#get_chars 0 l in
      try
	let i = Str.search_backward (Str.regexp_string s) t p in
	self#goto2 i (String.length s)
      with
	Not_found 
      |	Invalid_argument _ ->
	  try
	    let i = Str.search_backward (Str.regexp_string s) t (l-1) in
	    self#goto2 i (String.length s)
	  with
	    Not_found ->
	      ()

    method popup_contextual_menu () =
      match self#links_by_pos wt#position with
	[] -> ()
      | l ->
	  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
	  in
	  GToolbox.popup_menu ~button: 3 ~time: 0
	    ~entries: (List.map (fun c -> ` I c)
			 (List.flatten 
			    (List.map 
			       (fun link ->
				 match link with
				   LinkLink ele ->
				     ["Browse", 
				       (fun () -> 
					 let text_doc = new text_doc () in 
					 text_doc#window#show () ;
					 text_doc#push ele ;
				       )
				     ]  
				       
				 | LinkCode loc ->
				     (match loc.Odoc_info.loc_impl with
				       None -> []
				     | Some (file, pos) -> [file, f_edit file pos ]) @
				     (match loc.Odoc_info.loc_inter with
				       None -> []
				     | Some (file, pos) -> [file, f_edit file pos ])
			       )
					   l
			    )
			 )
		      )
        

    (** Search for a text in the current doc navigator window. 
       @action_command search
    *)
    method action_search () =
      if we_search#misc#has_focus then
	(
	 if we_search#text = "" then
	   we_search#set_text !last_search
	 else
	   self#goto_next_string ~force: true we_search#text
	)
      else
	(
	 let s = !last_search in
	 we_search#set_text "";
	 last_search := s;
	 we_search#misc#grab_focus ()
	)

    (** Search for a text backward in the current doc navigator window. 
       @action_command search_backward
    *)
    method action_search_backward () =
      if we_search#misc#has_focus then
	(
	 if we_search#text = "" then
	   we_search#set_text !last_search;
	 self#goto_previous_string we_search#text
	)
      else
	(
	 let s = !last_search in
	 we_search#set_text "";
	 last_search := s;
	 we_search#misc#grab_focus ()
	)

    (** Add the current element to the doc bookmarks. 
       @action_command add_bookmark
    *)
    method action_add_bookmark () = self#add_current_to_doc_bookmarks

    (** Goto the next element in the current doc navigator window.
       @action_command next_element
    *)
    method action_goto_next_element () = self#goto_next_element

   (** Goto the previous element in the current doc navigator window.
       @action_command previous_element
    *)
    method action_goto_previous_element () = self#goto_previous_element

    (** Follow link on the current cursor position. 
       @action_command follow_link
    *)
    method action_follow_link () = self#follow_current_position_link

    (** Follow link on the current cursor position, in a new window.
       @action_command follow_link_in_new
    *)
    method action_follow_link_in_new () = self#follow_current_position_link_in_new

    (** Go to the top of the current navigator window.
       @action_command home
    *)
    method action_home () = self#goto2 0 0

    (** Go to the end of the current navigator window.
       @action_command end
    *)
    method action_end () = self#goto2 (wt#length - 1) 0

    (** Popup the contextual menu. 
       @action_command menu
    *)
    method action_menu () =
      self#popup_contextual_menu ()

    initializer
      let _ = wt#event#connect#button_release ~callback:
	  (
	   fun ev ->
             GdkEvent.get_type ev = `BUTTON_RELEASE &&
	     (
	      match GdkEvent.Button.button ev with
		3 ->
		  (
		   self#popup_contextual_menu ();
		   true
		  )
	      |	1 ->
		  (match self#links_by_pos wt#position with
		  | (LinkLink ele) :: _ ->
		      self#push ele ;
		      true
		  | _ ->
		      true
		  )
	      |	_ ->
		  true
	     )
	  )
      in
      let _ = wb_back#connect#clicked (fun () -> self#pop) in

      (* Keyboard shortcuts *)
      let add = Cam_config.add_shortcut in 
      let module M = Cam_messages in
      let l_actions_window = [
	M.a_search, (None, self#action_search) ;
	M.a_back, (Some (fun () -> not we_search#misc#has_focus), wb_back#clicked) ;
	M.a_add_bookmark, (None, self#action_add_bookmark) ;
	M.a_next_element, (None, self#action_goto_next_element) ;
	M.a_prev_element, (None, self#action_goto_previous_element) ;
	M.a_close, (None, window#destroy) ;
	M.a_follow_link, (None, self#action_follow_link) ;
	M.a_follow_link_in_new, (None, self#action_follow_link_in_new) ;
	M.a_home, (None, self#action_home) ;
	M.a_end, (None, self#action_end) ;
	M.a_search_backward, (None, self#action_search_backward) ;
	M.a_menu, (None, self#action_menu) ;
      ]	
      in
      List.iter (add window l_actions_window) !!Cam_config.keymap_doc;

      let _ = we_search#connect#changed
	  (fun () -> self#goto_next_string we_search#text)
      in
      ()
  end

(** This function takes an element (result of a research), and display
   it in a new textdoc. *)
let display_result_element element =
  let text_doc = new text_doc () in
  let _ = text_doc#window#show () in
  let ele = 
    match element with
      Odoc_info.Search.Res_module m -> E_Module m.m_name
    | Odoc_info.Search.Res_module_type mt -> E_Module_type mt.mt_name
    | Odoc_info.Search.Res_class c -> E_Class c.cl_name
    | Odoc_info.Search.Res_class_type ct -> E_Class_type ct.clt_name
    | Odoc_info.Search.Res_value v -> E_Value v.val_name
    | Odoc_info.Search.Res_type t -> E_Type t.ty_name
    | Odoc_info.Search.Res_exception e -> E_Exception e.ex_name
    | Odoc_info.Search.Res_attribute a -> E_Attribute a.att_value.val_name
    | Odoc_info.Search.Res_method m -> E_Method m.met_value.val_name
    | Odoc_info.Search.Res_section (s, t) -> E_Section s
  in  
  text_doc#push ele


(** The window with the list of available modules. *)
let modules_window = ref (None : (GWindow.window * string GList.clist * GEdit.combo * string list) option)
(** The selected line, if any. *)
let selected_line = ref (None : (int * string) option)

(** Set the function which will be called when a key is pressed in the given wlist. *)
let wlist_key_stroke (wlist : string GList.clist) =
  let goto s =
    let l = match !modules_window with None -> [] | Some (_,_,_,l) -> l in
    let rec iter first_opt n = function
	[] -> first_opt
      |	name :: q ->
	  if String.length name > 0 then
	    if String.uppercase (String.sub name 0 1) = String.uppercase s then
	      match !selected_line with
		None -> Some n
	      |	Some (m, sel_name) ->
		  if String.length sel_name > 0 then
		    if Char.uppercase name.[0] = Char.uppercase sel_name.[0] then
		      if n <= m then
			match first_opt with
			  None -> iter (Some n) (n+1) q
			| Some _ -> iter first_opt (n+1) q
		      else
			Some n
		    else
		      Some n
		  else
		    Some n
	    else
	      iter first_opt (n+1) q
	  else
	    iter first_opt (n+1) q
    in
    match iter None 0 l with
      None -> ()
    | Some line ->
	wlist#moveto line 0 ;
	wlist#select line 0
  in
  let open_selected_module () =
    match !selected_line with
      None -> ()
    | Some (_, name) ->
	let text_doc = new text_doc () in
	let _ = text_doc#window#show () in
	let ele = E_Module name in
	text_doc#push ele
  in
  let _ = wlist#event#connect#key_press
    ~callback: (fun ev -> 
      (if GdkEvent.Key.keyval ev = GdkKeysyms._Return then
	open_selected_module ()
      else 
	goto (GdkEvent.Key.string ev)); 
      true)
  in
  let maybe_double_click (ev : GdkEvent.Button.t) = 
    let t = GdkEvent.get_type ev in
    match t with
      `TWO_BUTTON_PRESS -> open_selected_module ()
    | _ -> ()
  in
  ignore (wlist#connect#unselect_row
	    (fun ~row -> fun ~column -> fun ~event -> 
	      selected_line := None ;
	      match event with 
		None -> ()
	      |	Some ev -> maybe_double_click ev
	    )
	 ) ;
  ignore (wlist#connect#select_row 
	    (fun ~row -> fun ~column -> fun ~event -> 
	      let name = 
		match !modules_window with
		  None -> ""
		| Some (_,_,_,mods) -> try List.nth mods row with _ -> ""
	      in 
	      selected_line := Some (row, name) ;
	      match event with 
		None -> ()
	      |	Some ev -> maybe_double_click ev
	    )
	 )


(** Create or update the box with the list of available top modules. *)
let create_or_update_list_window () =
  let (window, wlist, wcombo) =
    match !modules_window with
      None ->
	let window = GWindow.window ~kind: `DIALOG 
	    ~title: Cam_messages.m_modules_box
	    ~x: 0
	    ~y: 0
	    ~width: 120 
	    ~height: 
	    (
	     let n = 80 + 20 * (List.length !Cam_doc.doc_modules) in
	     let h_limit = (Gdk.Screen.height ()) - 30 in
	     if n > h_limit then h_limit else n
	    ) 
	    ()
	in
	let vbox = GPack.vbox ~packing: window#add () in
	(*let hbox_search = GPack.hbox ~packing: (vbox#pack ~expand: false) () in*)
	let wcombo = GEdit.combo 
	    ~use_arrows: `DEFAULT
	    ~case_sensitive: true
	    ~value_in_list: false
	    ~ok_if_empty: true
	    ~packing: (vbox#pack ~expand: false)
	    ()
	in
	let wb_search = GButton.button 
	    ~label: Cam_messages.m_search_exact
	    ~packing: (vbox#pack ~expand: false)
	    ()
	in
	let wscroll = GBin.scrolled_window
	    ~hpolicy: `NEVER
	    ~vpolicy: `AUTOMATIC
	    ~packing: (vbox#pack ~expand: true)
	    () 
	in
	let wlist = GList.clist 
	    ~titles_show: false
	    ~titles: [""]
	    ~selection_mode: `SINGLE
	    ~packing: wscroll#add 
	    () 
	in
	wlist_key_stroke wlist ;
	let wb_close = GButton.button ~label: Cam_messages.close 
	    ~packing: (vbox#pack ~expand: false ~padding: 3) ()
	in
	let _ = window#connect#destroy
	    (fun () -> modules_window := None)
	in
	ignore (wb_close#connect#clicked window#destroy);
	ignore (wb_search#connect#clicked
		  (fun () ->
		    match wcombo#entry#text with
		      "" -> ()
		    | s -> !f_search_exact s
		  ));
	window#show () ;
	(window, wlist, wcombo)
    | Some (win, wlist, wcombo, _) -> (win, wlist, wcombo)
  in
  let _ = wlist#clear () in
  selected_line := None ;
  let _ = List.iter
      (fun m -> let _ = wlist#append [ m.m_name ] in ()) 
      !Cam_doc.doc_modules 
  in
  GToolbox.autosize_clist wlist;
  wcombo#set_popdown_strings !!Cam_config.doc_bookmarks;
  modules_window := Some (window, wlist, wcombo, List.map (fun m -> m.m_name) !Cam_doc.doc_modules) ;
  wlist#misc#grab_focus ()
  
  

(** Display a list of result elements. When one is selected, it is displayed. *)
let display_result_list elements =
  let window = GWindow.window ~kind: `DIALOG 
      ~width: 250 
      ~height: 
      (
       let n = 80 + 20 * (List.length elements) in
       if n > 500 then 500 else n
      ) 
      ()
  in
  let vbox = GPack.vbox ~packing: window#add () in
  let wscroll = GBin.scrolled_window ~packing: (vbox#pack ~expand: true) () in
  let wlist = GList.clist 
      ~titles: [ Cam_messages.kind ; Cam_messages.name ]
      ~titles_show: true
      ~selection_mode: `SINGLE
      ~packing: wscroll#add 
      () 
  in
  let wb_close = GButton.button ~label: Cam_messages.close 
      ~packing: (vbox#pack ~expand: false ~padding: 3) ()
  in
  List.iter
    (fun ele -> 
     let l = 
       match ele with
	 Odoc_info.Search.Res_module m -> [ "module" ; m.m_name ]
       | Odoc_info.Search.Res_module_type mt -> [ "module type" ; mt.mt_name ]
       | Odoc_info.Search.Res_class c -> [ "class" ; c.cl_name ]
       | Odoc_info.Search.Res_class_type ct -> [ "class type" ; ct.clt_name ]
       | Odoc_info.Search.Res_value v -> [ "value" ; v.val_name ]
       | Odoc_info.Search.Res_type t -> [ "type" ; t.ty_name ]
       | Odoc_info.Search.Res_exception e -> [ "exception" ; e.ex_name ]
       | Odoc_info.Search.Res_attribute a -> [ "attribute" ; a.att_value.val_name ]
       | Odoc_info.Search.Res_method m -> [ "method" ; m.met_value.val_name ]
       | Odoc_info.Search.Res_section (s, t) -> [ "section" ; s ]
     in
     let _ = wlist#append l in
     ()
    )
    elements;
  GToolbox.autosize_clist wlist ;
  let _ = wb_close#connect#clicked window#destroy in
  let f ~row ~column ~event =
    try
      let ele = List.nth elements row in
      display_result_element ele
    with
      Not_found -> ()
  in
  let _ = wlist#connect#select_row f in
  window#show ()

(**  This function search in loaded modules for the elements with the
   given exact name. If only one element is found, it is displayed
   in a textdoc. If more than one element 
   are found, a box is displayed with the list. If no element is found,
   a message box is displayed.*)
let search_elements_by_exact_names s =
  match Odoc_info.Search.search_by_name 
      !Cam_doc.doc_modules (Str.regexp ("^"^(Str.quote s)^"$"))
  with
    [] ->
      GToolbox.message_box Cam_messages.m_search_exact
	(Cam_messages.nothing_found s)
  | [ele] ->
      display_result_element ele
  | l ->
      display_result_list l

(** Make the user type a string and look in the loaded modules
   for the elements with that name exactly.*)
let search_exact () =
  match GToolbox.input_string ~title:Cam_messages.m_search_exact "" with
    None -> ()
  | Some s -> search_elements_by_exact_names s
      
(** Make the user type a regexp and look in the loaded modules
   for the elements with that name exactly. If only one element
   is found, it is displayed in a textdoc. If more than one element 
   are found, a box is displayed with the list. If no element is found,
   a message box is displayed.*)
let search_regexp () =
  match GToolbox.input_string Cam_messages.m_search_regexp "" with
    None ->
      ()
  | Some s ->
      match Odoc_info.Search.search_by_name 
	  !Cam_doc.doc_modules (Str.regexp s) 
      with
	[] ->
	  GToolbox.message_box Cam_messages.m_search_regexp
	    (Cam_messages.nothing_found s)
      |	[ele] ->
	  display_result_element ele
      |	l ->
	  display_result_list l

(** Function to call to update the module box, if it is displayed. *)
let update_module_box_if_displayed () =
  match !modules_window with
    None -> ()
  | Some _ -> create_or_update_list_window ()

(* Initialize global functions. *)

let _ = f_search_exact := search_elements_by_exact_names
let _ = f_update_bookmarks := update_module_box_if_displayed
