<commit_before>(***********************************************************************)
(*                             OCamldoc                                *)
(*                                                                     *)
(*            <NAME>, <NAME>, INRIA Rocquencourt      *)
(*                                                                     *)
(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)


(** Analysis of implementation files. *)
open Misc
open Asttypes
open Types
open Typedtree

let print_DEBUG3 s = print_string s ; print_newline ();;
let print_DEBUG s = print_string s ; print_newline ();;

type typedtree = (Typedtree.structure * Typedtree.module_coercion)

module Name = Odoc_name
open Odoc_parameter
open Odoc_value
open Odoc_type
open Odoc_exception
open Odoc_class
open Odoc_module
open Odoc_types

(** This variable contains the regular expression representing a blank.*)
let blank = "[ \010\013\009\012']"
(** This variable contains the regular expression representing a blank but not a '\n'.*)
let simple_blank = "[ \013\009\012]"


(** This module is used to search for structure items by name in a Typedtree.structure. *)
module Typedtree_search =
  struct
    let search_module typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_module (ident, module_expr)) :: q when 
	    (Name.from_ident ident) = name ->
	      module_expr
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_module_type typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_modtype (ident, module_type)) :: q when 
	    (Name.from_ident ident) = name ->
	      module_type
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_exception typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_exception (ident, excep_decl)) :: q when 
	    (Name.from_ident ident) = name ->
	      excep_decl
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_exception_rebind typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_exn_rebind (ident, p)) :: q when 
	    (Name.from_ident ident) = name ->
	      p
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_type_declaration typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_type ident_type_decl_list) :: q ->
	    (
	     try
	       snd (List.find
		      (fun (id, _) -> Name.from_ident id = name)
		      ident_type_decl_list)
	     with
	       Not_found ->
		 iter q
	    )
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_class_exp typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_class info_list) :: q ->
	    (
	     try
	       let (_,_,_,ce) = (List.find
				   (fun (id, _, _, class_expr) -> Name.from_ident id = name)
				   info_list)
	       in
	       (* We look for the type artificially created for the class,
		  to get the list of type parameters. *)
	       try
		 let type_decl = search_type_declaration typedtree name in
		 (ce, type_decl.Types.type_params)
	       with
		 Not_found ->
		   (ce, [])
	     with
	       Not_found ->
		 iter q
	    )
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_class_type_declaration typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_cltype info_list) :: q ->
	    (
	     try
	       let (_, cltype_decl) = (List.find
					 (fun (id, clty_d) -> Name.from_ident id = name)
					 info_list)
	       in
	       cltype_decl
	     with
	       Not_found ->
		 iter q
	    )
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_value typedtree name =
      let rec iter_pat = function
	| Typedtree.Tpat_any -> None
	| Typedtree.Tpat_var name -> Some (Name.from_ident name)
	| Typedtree.Tpat_tuple _ -> None (* A VOIR quand on traitera les tuples *)
	| _ -> None
      in
      let pred (pat, _) = 
	match iter_pat pat.Typedtree.pat_desc with
	| Some n when n = name -> true
	| _ -> false
      in
      let rec iter = function 
	  [] ->
	    raise Not_found
	| item :: q ->
	    match item with
	      Tstr_value (_, pat_exp_list) ->
		(
		 try
		   List.find pred pat_exp_list
		 with
		   Not_found ->
		     iter q
		)
	    | _ ->
		iter q
      in
      iter typedtree

    let search_primitive typedtree name =
      let rec iter = function 
	  [] ->
	    raise Not_found
	| item :: q ->
	    match item with
	      Tstr_primitive (ident, val_desc) ->
		(
		 if Name.from_ident ident = name then
		   val_desc.Types.val_type
		 else
		   iter q
		)
	    | _ ->
		iter q
      in
      iter typedtree

    let get_nth_inherit_class_expr cls n =
      let rec iter cpt = function
	| [] ->
	    raise Not_found
	| Typedtree.Cf_inher (clexp, _, _) :: q ->
	    if n = cpt then clexp else iter (cpt+1) q
	| _ :: q ->
	    iter cpt q
      in
      iter 0 cls.Typedtree.cl_field

    let search_attribute_type cls name =
      let rec iter = function
	| [] ->
	    raise Not_found
	| Typedtree.Cf_val (_, ident, exp) :: q 
	  when Name.from_ident ident = name ->
	    exp.Typedtree.exp_type
	| _ :: q ->
	    iter q
      in
      iter cls.Typedtree.cl_field

   let search_method_expression cls name =
      let rec iter = function
	| [] ->
	    raise Not_found
	| Typedtree.Cf_meth (label, exp) :: q when label = name ->
	    exp
	| _ :: q ->
	    iter q
      in
      iter cls.Typedtree.cl_field
  end

module Analyser = 
  functor (My_ir : Odoc_sig.Info_retriever) ->

  struct
    module Sig = Odoc_sig.Analyser (My_ir)

    (** This variable is used to load a file as a string and retrieve characters from it.*)
    let file = Sig.file

    (** The name of the analysed file. *)
    let file_name = Sig.file_name

    (** This function takes two indexes (start and end) and return the string
       corresponding to the indexes in the file global variable. The function
       prepare_file must have been called to fill the file global variable.*)
    let get_string_of_file = Sig.get_string_of_file

    (** This function loads the given file in the file global variable.
       and sets file_name.*)
    let prepare_file = Sig.prepare_file

    (** The function used to get the comments in a class. *)
    let get_comments_in_class = Sig.get_comments_in_class

    (** The function used to get the comments in a module. *)
    let get_comments_in_module = Sig.get_comments_in_module

    (** This function takes a parameter pattern and builds the 
       corresponding [parameter] structure. The f_desc function
       is used to retrieve a parameter description, if any, from
       a parameter name.
    *)
    let tt_param_info_from_pattern env f_desc pat =
      let rec iter_pattern pat =
	match pat.pat_desc with
	  Typedtree.Tpat_var ident ->
	    let name = Name.from_ident ident in
	    Simple_name { sn_name = name ;
			  sn_text = f_desc name ;
			  sn_type = Odoc_env.subst_type env pat.pat_type
			} 
	      
	| Typedtree.Tpat_alias (pat, _) ->
	    iter_pattern pat

	| Typedtree.Tpat_tuple patlist ->
	    Tuple
	      (List.map iter_pattern patlist,
	       Odoc_env.subst_type env pat.pat_type)
	      
	| Typedtree.Tpat_construct (cons_desc, _) when 
	    (* we give a name to the parameter only if it unit *)
	    (match cons_desc.cstr_res.desc with
	      Tconstr (p, _, _) ->
		Path.same p Predef.path_unit 
	    | _ ->
		false)
	  ->
	    (* a () argument, it never has description *)
	    Simple_name { sn_name = "()" ;
			  sn_text = None ;
			  sn_type = Odoc_env.subst_type env pat.pat_type
			} 

	| _ ->
            (* implicit pattern matching -> anonymous parameter *)
	    Simple_name { sn_name = "()" ;
			  sn_text = None ;
			  sn_type = Odoc_env.subst_type env pat.pat_type
			} 
      in
      iter_pattern pat 

    (** Analysis of the parameter of a function. Return a list of t_parameter created from
       the (pattern, expression) structures encountered. *)
    let rec tt_analyse_function_parameters env current_comment_opt pat_exp_list =
      match pat_exp_list with
	[] ->
	  (* This case means we have a 'function' without pattern, that's impossible *)
	  raise (Failure "tt_analyse_function_parameters: 'function' without pattern")

      |	(pattern_param, exp) :: second_ele :: q ->
          (* implicit pattern matching -> anonymous parameter and no more parameter *)
	  (* A VOIR : le label ? *)
	  let parameter = (Odoc_parameter.Tuple ([], Odoc_env.subst_type env pattern_param.pat_type), "") in
	  [ parameter ]

      | (pattern_param, func_body) :: [] ->
	  let parameter = 
	    (tt_param_info_from_pattern 
	       env
	       (Odoc_parameter.desc_from_info_opt current_comment_opt) 
	       pattern_param,
	     "") (* A VOIR : le label ? *)
	  in
         (* For optional parameters with a default value, a special treatment is required *)
         (* we look if the name of the parameter we just add is "*opt*", which means
	    that there is a let param_name = ... in ... just right now *)
	  let (p, next_exp) = 
	    match parameter with
	      (Simple_name { sn_name = "*opt*" }, label) ->
		(
		 (
		  match func_body.exp_desc with
		    Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, func_body2) ->
		      let name = Name.from_ident id in
		      let new_param = 
			(Simple_name { sn_name = name ;
				       sn_text = Odoc_parameter.desc_from_info_opt current_comment_opt name ;
				       sn_type = Odoc_env.subst_type env exp.exp_type
				     },
			 label)
		      in
		      (new_param, func_body2)
		  | _ ->
		      print_DEBUG3 "Pas le bon filtre pour le paramtre optionnel avec valeur par dfaut.";
		      (parameter, func_body)
		 )
		)
	    | _ ->
		(parameter, func_body)
	  in
         (* continue if the body is still a function *)
	  match next_exp.exp_desc with
	    Texp_function (pat_exp_list, _) ->
	      p :: (tt_analyse_function_parameters env current_comment_opt pat_exp_list)
	  | _ ->
              (* something else ; no more parameter *)
	      [ p ]

     (** Analysis of a Tstr_value from the typedtree. Create and return a list of [t_value].
	@raise Failure if an error occurs.*)
     let tt_analyse_value env current_module_name comment_opt loc pat_exp rec_flag =
       let (pat, exp) = pat_exp in
       match (pat.pat_desc, exp.exp_desc) with
	 (Typedtree.Tpat_var ident, Typedtree.Texp_function (pat_exp_list2, partial)) ->
           (* a new function is defined *)
	   let name_pre = Name.from_ident ident in
	   let name = Name.parens_if_infix name_pre in
	   let complete_name = Name.concat current_module_name name in
 	   (* create the value *)
	   let new_value = {
	     val_name = complete_name ;
	     val_info = comment_opt ;
	     val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ;
	     val_recursive = rec_flag = Asttypes.Recursive ;
	     val_parameters = tt_analyse_function_parameters env comment_opt pat_exp_list2 ;
	     val_code = Some (get_string_of_file loc.Location.loc_start loc.Location.loc_end) ;
	     val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; loc_inter = None } ;
	   }	
	   in
	   [ new_value ]
	     
       | (Typedtree.Tpat_var ident, _) ->
	   (* a new value is defined *)	    
	   let name_pre = Name.from_ident ident in
	   let name = Name.parens_if_infix name_pre in
	   let complete_name = Name.concat current_module_name name in
	   let new_value = {
	     val_name = complete_name ;
	     val_info = comment_opt ;
	     val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ;
	     val_recursive = rec_flag = Asttypes.Recursive ;
	     val_parameters = [] ;
	     val_code = Some (get_string_of_file loc.Location.loc_start loc.Location.loc_end) ;
	     val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; loc_inter = None } ;
	   }	
	   in
	   [ new_value ]
	     
       | (Typedtree.Tpat_tuple lpat, _) ->
	   (* new identifiers are defined *)
	   (* A VOIR : by now we don't accept to have global variables defined in tuples *)
	   []
	     
       | _ ->
	   (* something else, we don't care ? A VOIR *)
	   []

    (** This function converts a Types.type_kind into a Odoc_type.type_kind,
       by analysing the comment of each constructor/field, if any.
       @param pos_start is the start position of the type definition.
       @param pos_end is the end position of the type definition.
       @param pos_limit is the position of the last character which can be
       used for a comment, for the variant types, where [pos_end] is not enough
       since we can have comments after this position.
       @return the type kind and the position of the last used character,
       that is the end position of the last character of the comment
       for the last constructor, if the type is a variant. If the type is
       not a variant, then the last position is the [pos_end] parameter.
    *)
    let tt_get_type_kind env pos_start pos_end pos_limit type_kind =
      match type_kind with
	Types.Type_abstract ->
	  (Odoc_type.Type_abstract, pos_end)

      | Types.Type_variant l (*(string * type_expr list) list*) ->
	  let rec f acc last_pos l =
	    match l with
	      [] ->
		(acc, last_pos)
	    | (constructor_name, type_expr_list) :: q ->
                (* we don't have location info, so we try to
		   get it by searching for regexp "constructor_name(blank)*(of)?" from the
		   last location. *)
		let loc_start = 
		  try Str.search_forward (Str.regexp (constructor_name^blank^"*\\(of\\)?")) !file last_pos
		  with
		    Not_found -> 
		      print_DEBUG3 (constructor_name^blank^"*\\(of\\)? n'a rien donn.");
		      last_pos
		in
		let loc_end =
		  match q with
		    [] -> pos_limit 
		  | (constructor_name2, type_expr_list2) :: _ ->
		      try Str.search_forward (Str.regexp ("|"^blank^"*"^constructor_name2^blank^"*\\(of\\)?")) !file loc_start
		      with 
			Not_found -> 
			  print_DEBUG3 (blank^"+|"^constructor_name2^blank^"*\\(of\\)? n'a rien donn.");
			  loc_start
		in
                (* get the comment *)
		let s = get_string_of_file loc_start loc_end in
		let (len, info_opt) = My_ir.just_after_special !file_name  s in
		let new_acc = 
		  acc @ [
			{
			  vc_name = constructor_name ;
			  vc_args = List.map (Odoc_env.subst_type env) type_expr_list ;
			  vc_text = 
			  (match info_opt with 
			    None -> 
			     print_DEBUG3 ("Pas de description pour le constructeur "^constructor_name);
			      None
			  | Some d ->
			      d.Odoc_types.i_desc)
			} 
		      ]
		in
		f new_acc (loc_start + len) q
	  in
	  let (l_cons, new_last_pos) = f [] pos_start l in
	  (Odoc_type.Type_variant l_cons, new_last_pos)

      | Types.Type_record (l, _) ->
          (*(string * mutable_flag * type_expr) list * record_representation *)
	  let rec f acc last_pos l =
	    match l with
	      [] ->
		acc
	    | (field_name, mutable_flag, type_expr) :: q ->
                (* we don't have location info, so we try to
		get it by searching for regexp "(mutable)?blank*field_name(blank)*:" from the
		last location. *)
		let loc_start = 
		  (
		   let regexp = "\\(mutable\\)?"^blank^"*"^field_name^blank^"*:" in
		   try 
		     Str.search_forward (Str.regexp regexp) !file last_pos
		   with Not_found -> 
		     print_DEBUG3 (regexp^" n'a rien donn.");
		     last_pos
		  ) 
		in
		let loc_end = 
		  match q with
		    [] -> pos_end
		  | (field_name2, mutable_flag2, type_expr2) :: _ ->
		      let regexp = "\\(mutable\\)?"^blank^"*"^field_name2^blank^"*:" in
		      try 
			Str.search_forward (Str.regexp regexp) !file loc_start
		      with Not_found -> 
			print_DEBUG3 (regexp^" n'a rien donn.");
			loc_start
		in
                (* get the comment *)
		let s = get_string_of_file loc_start loc_end in
		let (len, info_opt) = My_ir.just_after_special !file_name  s in
		let new_acc = 
		  acc @ [
			{
			  rf_name = field_name ;
			  rf_mutable = mutable_flag = Mutable ;
			  rf_type = Odoc_env.subst_type env type_expr ; 
			  rf_text = 
			      (match info_opt with 
				None -> 
				  print_DEBUG3 ("Pas de description pour le champ "^field_name);
				  None
			      | Some d ->
				  d.Odoc_types.i_desc)
			} 
		      ]
		in
		f new_acc (loc_start + len) q
	  in
	  (Odoc_type.Type_record (f [] pos_start l), pos_end)


    (** This function takes a Typedtree.class_expr and returns a string which can stand for the class name.
       The name can be "object ... end" if the class expression is not an ident or a class constraint or a class apply. *)
    let rec tt_name_of_class_expr clexp =
      match clexp.Typedtree.cl_desc with
	Typedtree.Tclass_ident p -> Name.from_path p
      |	Typedtree.Tclass_constraint (class_expr, _, _, _)
      |	Typedtree.Tclass_apply (class_expr, _) -> tt_name_of_class_expr class_expr
(*
      |	Typedtree.Tclass_fun (_, _, class_expr, _) -> tt_name_of_class_expr class_expr
      |	Typedtree.Tclass_let (_,_,_, class_expr) -> tt_name_of_class_expr class_expr
*)
      |	 _ -> Odoc_messages.object_end

    (** Analysis of a method expression to get the method parameters. 
       @param first indicates if we're analysing the method for
       the first time ; in that case we must not keep the first parameter,
       which is "self-*", the object itself.
    *)
    let rec tt_analyse_method_expression env current_method_name comment_opt ?(first=true) exp =
      match exp.Typedtree.exp_desc with
	Typedtree.Texp_function (pat_exp_list, _) ->
	  (
	   match pat_exp_list with
	     [] ->
	       (* it is not a function since there are no parameters *)
	       (* we can't get here normally *)
	       raise (Failure (Odoc_messages.bad_tree^" "^(Odoc_messages.method_without_param current_method_name)))
	   | l ->
	       match l with
		 [] ->
		   (* cas impossible, on l'a filtr avant *)
		   assert false
	       | (pattern_param, exp) :: second_ele :: q ->
                   (* implicit pattern matching -> anonymous parameter *)
		   (* Note : We can't match this pattern if it is the first call to the function. *)
		   let new_param = 
		     (Simple_name { sn_name = "??" ; sn_text =  None; 
				    sn_type = Odoc_env.subst_type env pattern_param.Typedtree.pat_type },
		      "") (* A VOIR : le label ? *)
		   in
		   [ new_param ]
		     
	       | (pattern_param, body) :: [] ->
		   (* if this is the first call to the function, this is the first parameter and we skip it *)
		   if not first then
		     (
		      let parameter = 
			(tt_param_info_from_pattern
			   env
			   (Odoc_parameter.desc_from_info_opt comment_opt) 
			   pattern_param ,
			 "") (* A VOIR : le label ? *)
		      in
                      (* For optional parameters with a default value, a special treatment is required. *)
                      (* We look if the name of the parameter we just add is "*opt*", which means
			 that there is a let param_name = ... in ... just right now. *)
		      let (current_param, next_exp) = 
			match parameter with
			  (Simple_name { sn_name = "*opt*"}, label) ->
			    (
			     (
			      match body.exp_desc with
				Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, body2) ->
				  let name = Name.from_ident id in
				  let new_param = 
				    (Simple_name { sn_name = name ;
						   sn_text = Odoc_parameter.desc_from_info_opt comment_opt name ;
						   sn_type = Odoc_env.subst_type env exp.Typedtree.exp_type ; 
						 },
				     label)
				  in
				  (new_param, body2)
			      | _ ->
				  print_DEBUG3 "Pas le bon filtre pour le paramtre optionnel avec valeur par dfaut.";
				  (parameter, body)
			     )
			    )
			| _ ->
  	                    (* no *opt* parameter, we add the parameter then continue *)
			    (parameter, body)
		      in
		      current_param :: (tt_analyse_method_expression env current_method_name comment_opt ~first: false next_exp)
		     )
		   else
		     tt_analyse_method_expression env current_method_name comment_opt ~first: false body
	  )
      | _ ->
	  (* no more parameter *)
	  []

    (** Analysis of a [Parsetree.class_struture] and a [Typedtree.class_structure] to get a couple 
       (inherited classes, class elements). *)
    let analyse_class_structure env current_class_name tt_class_sig last_pos pos_limit p_cls tt_cls =
      let rec iter acc_inher acc_fields last_pos = function
	| [] -> 
	    let s = get_string_of_file last_pos pos_limit in
	    let (_, ele_coms) = My_ir.all_special !file_name s in
	    let ele_comments =
	      List.fold_left
		(fun acc -> fun sc ->
		  match sc.Odoc_types.i_desc with
		    None ->
		      acc
		  | Some t ->
		      acc @ [Class_comment t])
		[]
		ele_coms
	    in
	    (acc_inher, acc_fields @ ele_comments)

	| (Parsetree.Pcf_inher (p_clexp, _)) :: q  ->
	    let tt_clexp =
	      let n = List.length acc_inher in
	      try Typedtree_search.get_nth_inherit_class_expr tt_cls n
	      with Not_found -> raise (Failure (Odoc_messages.inherit_classexp_not_found_in_typedtree n))
	    in
	    let (info_opt, ele_comments) = get_comments_in_class last_pos p_clexp.Parsetree.pcl_loc.Location.loc_start in
	    let text_opt = match info_opt with None -> None | Some i -> i.Odoc_types.i_desc in
	    let name = tt_name_of_class_expr tt_clexp in
	    let inher = { ic_name = Odoc_env.full_class_or_class_type_name env name ; ic_class = None ; ic_text = text_opt }  in
	    iter (acc_inher @ [ inher ]) (acc_fields @ ele_comments)
	      p_clexp.Parsetree.pcl_loc.Location.loc_end
	      q

	| (Parsetree.Pcf_val (label, mutable_flag, expression, loc)) :: q ->
	    let complete_name = Name.concat current_class_name label in
	    let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start in
	    let type_exp =
	      try Typedtree_search.search_attribute_type tt_cls label
	      with Not_found -> raise (Failure (Odoc_messages.attribute_not_found_in_typedtree complete_name))
	    in
	    let att =
	      {
		att_value = { val_name = complete_name ; 
			      val_info = info_opt ;
			      val_type = Odoc_env.subst_type env type_exp ;
			      val_recursive = false ;
			      val_parameters = [] ; 
			      val_code = Some (get_string_of_file loc.Location.loc_start loc.Location.loc_end) ;
			      val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; loc_inter = None } ;
			    } ;
		att_mutable = mutable_flag = Asttypes.Mutable ;
	      }	
	    in
	    iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end q
      
	| (Parsetree.Pcf_virt  (label, private_flag, _, loc)) :: q ->
	    let complete_name = Name.concat current_class_name label in
	    let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start in
	    let met_type = 
	      try Odoc_sig.Signature_search.search_method_type label tt_class_sig 
	      with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label))
	    in
	    let real_type =
	      match met_type.Types.desc with
		Tarrow (_, _, t, _) ->
		  t
	      |  _ ->
     	        (* ?!? : not an arrow type ! return the original type *)
		  met_type
	    in
	    let met = 
	      {
		met_value = { val_name = complete_name ;
			      val_info = info_opt ;
			      val_type = Odoc_env.subst_type env real_type ;
			      val_recursive = false ;
			      val_parameters = [] ;
			      val_code = Some (get_string_of_file loc.Location.loc_start loc.Location.loc_end) ;
			      val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; loc_inter = None } ;
			    } ;
		met_private = private_flag = Asttypes.Private ;
		met_virtual = true ;
	      }	
	    in
      	    (* update the parameter description *)
	    Odoc_value.update_value_parameters_text met.met_value;

	    iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end q

	| (Parsetree.Pcf_meth  (label, private_flag, _, loc)) :: q ->
	    let complete_name = Name.concat current_class_name label in
	    let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start in
	    let exp = 
	      try Typedtree_search.search_method_expression tt_cls label
	      with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name))
	    in
	    let real_type =
	      match exp.exp_type.desc with
		Tarrow (_, _, t,_) ->
		  t
	      |  _ ->
     	        (* ?!? : not an arrow type ! return the original type *)
		  exp.Typedtree.exp_type
	    in
	    let met = 
	      {
		met_value = { val_name = complete_name ;
			      val_info = info_opt ;
			      val_type = Odoc_env.subst_type env real_type ;
			      val_recursive = false ;
			      val_parameters = tt_analyse_method_expression env complete_name info_opt exp ;
			      val_code = Some (get_string_of_file loc.Location.loc_start loc.Location.loc_end) ;
			      val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; loc_inter = None } ;
			    } ;
		met_private = private_flag = Asttypes.Private ;
		met_virtual = false ;
	      }	
	    in
      	    (* update the parameter description *)
	    Odoc_value.update_value_parameters_text met.met_value;

	    iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end q
	    
	| Parsetree.Pcf_cstr (_, _, loc) :: q ->
	    (* don't give a $*%@ ! *)
	    iter acc_inher acc_fields loc.Location.loc_end q

	| Parsetree.Pcf_let (_, _, loc) :: q ->
	    (* don't give a $*%@ ! *)
	    iter acc_inher acc_fields loc.Location.loc_end q

	| (Parsetree.Pcf_init exp) :: q ->
	    iter acc_inher acc_fields exp.Parsetree.pexp_loc.Location.loc_end q
      in
      iter [] [] last_pos (snd p_cls)
	      
    (** Analysis of a [Parsetree.class_expr] and a [Typedtree.class_expr] to get a a couple (class parameters, class kind). *)
    let rec analyse_class_kind env current_class_name comment_opt last_pos p_class_expr tt_class_exp =
      match (p_class_expr.Parsetree.pcl_desc, tt_class_exp.Typedtree.cl_desc) with
	(Parsetree.Pcl_constr (lid, _), tt_class_exp_desc ) -> 
	  let name = 
	    match tt_class_exp_desc with
	      Typedtree.Tclass_ident p -> Name.from_path p 
	    | _ ->
		(* we try to get the name from the environment. *)
                (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( mme quand on a class tutu = toto *)
		Name.from_longident lid
	  in
	  (* On n'a pas ici les paramtres de type sous forme de Types.type_expr,
	     par contre on peut les trouver dans le class_type *)
	  let params = 
	    match tt_class_exp.Typedtree.cl_type with
	      Types.Tcty_constr (p2, type_exp_list, cltyp) ->
		(* cltyp is the class type for [type_exp_list] p *)
		type_exp_list
	    | _ ->
		[]
	  in
	  ([], 
	   Class_constr
	     {
	       cco_name = Odoc_env.full_class_name env name ;
	       cco_class = None ;
	       cco_type_parameters = List.map (Odoc_env.subst_type env) params ; 
	     } )

      | (Parsetree.Pcl_structure p_class_structure, Typedtree.Tclass_structure tt_class_structure) ->
	  (* we need the class signature to get the type of methods in analyse_class_structure *)
	  let tt_class_sig = 
	    match tt_class_exp.Typedtree.cl_type with
	      Types.Tcty_signature class_sig -> class_sig
	    | _ -> raise (Failure "analyse_class_kind: no class signature for a class structure.")
	  in
	  let (inherited_classes, class_elements) = analyse_class_structure 
	      env
	      current_class_name 
	      tt_class_sig
	      last_pos
	      p_class_expr.Parsetree.pcl_loc.Location.loc_end
	      p_class_structure
	      tt_class_structure
	  in
	  ([],
	   Class_structure (inherited_classes, class_elements) )
	    
      | (Parsetree.Pcl_fun (label, expression_opt, pattern, p_class_expr2),
	 Typedtree.Tclass_fun (pat, ident_exp_list, tt_class_expr2, partial)) ->
	   (* we check that this is not an optional parameter with
	      a default value. In this case, we look for the good parameter pattern *)
	   prerr_endline ("label="^label);
	   let (parameter, next_tt_class_exp) =
	     match pat.Typedtree.pat_desc with
	       Typedtree.Tpat_var ident when Name.from_ident ident = "*opt*" ->
		 (
		  (* there must be a Tclass_let just after *)
		  match tt_class_expr2.Typedtree.cl_desc with
		    Typedtree.Tclass_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, _, tt_class_expr3) ->
		      let name = Name.from_ident id in
		      let new_param = <commit_msg>enlèvement trace<commit_after>(***********************************************************************)
(*                             OCamldoc                                *)
(*                                                                     *)
(*            <NAME>, <NAME>, INRIA Rocquencourt      *)
(*                                                                     *)
(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)


(** Analysis of implementation files. *)
open Misc
open Asttypes
open Types
open Typedtree

let print_DEBUG3 s = print_string s ; print_newline ();;
let print_DEBUG s = print_string s ; print_newline ();;

type typedtree = (Typedtree.structure * Typedtree.module_coercion)

module Name = Odoc_name
open Odoc_parameter
open Odoc_value
open Odoc_type
open Odoc_exception
open Odoc_class
open Odoc_module
open Odoc_types

(** This variable contains the regular expression representing a blank.*)
let blank = "[ \010\013\009\012']"
(** This variable contains the regular expression representing a blank but not a '\n'.*)
let simple_blank = "[ \013\009\012]"


(** This module is used to search for structure items by name in a Typedtree.structure. *)
module Typedtree_search =
  struct
    let search_module typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_module (ident, module_expr)) :: q when 
	    (Name.from_ident ident) = name ->
	      module_expr
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_module_type typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_modtype (ident, module_type)) :: q when 
	    (Name.from_ident ident) = name ->
	      module_type
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_exception typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_exception (ident, excep_decl)) :: q when 
	    (Name.from_ident ident) = name ->
	      excep_decl
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_exception_rebind typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_exn_rebind (ident, p)) :: q when 
	    (Name.from_ident ident) = name ->
	      p
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_type_declaration typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_type ident_type_decl_list) :: q ->
	    (
	     try
	       snd (List.find
		      (fun (id, _) -> Name.from_ident id = name)
		      ident_type_decl_list)
	     with
	       Not_found ->
		 iter q
	    )
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_class_exp typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_class info_list) :: q ->
	    (
	     try
	       let (_,_,_,ce) = (List.find
				   (fun (id, _, _, class_expr) -> Name.from_ident id = name)
				   info_list)
	       in
	       (* We look for the type artificially created for the class,
		  to get the list of type parameters. *)
	       try
		 let type_decl = search_type_declaration typedtree name in
		 (ce, type_decl.Types.type_params)
	       with
		 Not_found ->
		   (ce, [])
	     with
	       Not_found ->
		 iter q
	    )
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_class_type_declaration typedtree name =
      let rec iter = function
	  [] -> raise Not_found
	| (Typedtree.Tstr_cltype info_list) :: q ->
	    (
	     try
	       let (_, cltype_decl) = (List.find
					 (fun (id, clty_d) -> Name.from_ident id = name)
					 info_list)
	       in
	       cltype_decl
	     with
	       Not_found ->
		 iter q
	    )
	| _ :: q ->
	    iter q
      in
      iter typedtree

    let search_value typedtree name =
      let rec iter_pat = function
	| Typedtree.Tpat_any -> None
	| Typedtree.Tpat_var name -> Some (Name.from_ident name)
	| Typedtree.Tpat_tuple _ -> None (* A VOIR quand on traitera les tuples *)
	| _ -> None
      in
      let pred (pat, _) = 
	match iter_pat pat.Typedtree.pat_desc with
	| Some n when n = name -> true
	| _ -> false
      in
      let rec iter = function 
	  [] ->
	    raise Not_found
	| item :: q ->
	    match item with
	      Tstr_value (_, pat_exp_list) ->
		(
		 try
		   List.find pred pat_exp_list
		 with
		   Not_found ->
		     iter q
		)
	    | _ ->
		iter q
      in
      iter typedtree

    let search_primitive typedtree name =
      let rec iter = function 
	  [] ->
	    raise Not_found
	| item :: q ->
	    match item with
	      Tstr_primitive (ident, val_desc) ->
		(
		 if Name.from_ident ident = name then
		   val_desc.Types.val_type
		 else
		   iter q
		)
	    | _ ->
		iter q
      in
      iter typedtree

    let get_nth_inherit_class_expr cls n =
      let rec iter cpt = function
	| [] ->
	    raise Not_found
	| Typedtree.Cf_inher (clexp, _, _) :: q ->
	    if n = cpt then clexp else iter (cpt+1) q
	| _ :: q ->
	    iter cpt q
      in
      iter 0 cls.Typedtree.cl_field

    let search_attribute_type cls name =
      let rec iter = function
	| [] ->
	    raise Not_found
	| Typedtree.Cf_val (_, ident, exp) :: q 
	  when Name.from_ident ident = name ->
	    exp.Typedtree.exp_type
	| _ :: q ->
	    iter q
      in
      iter cls.Typedtree.cl_field

   let search_method_expression cls name =
      let rec iter = function
	| [] ->
	    raise Not_found
	| Typedtree.Cf_meth (label, exp) :: q when label = name ->
	    exp
	| _ :: q ->
	    iter q
      in
      iter cls.Typedtree.cl_field
  end

module Analyser = 
  functor (My_ir : Odoc_sig.Info_retriever) ->

  struct
    module Sig = Odoc_sig.Analyser (My_ir)

    (** This variable is used to load a file as a string and retrieve characters from it.*)
    let file = Sig.file

    (** The name of the analysed file. *)
    let file_name = Sig.file_name

    (** This function takes two indexes (start and end) and return the string
       corresponding to the indexes in the file global variable. The function
       prepare_file must have been called to fill the file global variable.*)
    let get_string_of_file = Sig.get_string_of_file

    (** This function loads the given file in the file global variable.
       and sets file_name.*)
    let prepare_file = Sig.prepare_file

    (** The function used to get the comments in a class. *)
    let get_comments_in_class = Sig.get_comments_in_class

    (** The function used to get the comments in a module. *)
    let get_comments_in_module = Sig.get_comments_in_module

    (** This function takes a parameter pattern and builds the 
       corresponding [parameter] structure. The f_desc function
       is used to retrieve a parameter description, if any, from
       a parameter name.
    *)
    let tt_param_info_from_pattern env f_desc pat =
      let rec iter_pattern pat =
	match pat.pat_desc with
	  Typedtree.Tpat_var ident ->
	    let name = Name.from_ident ident in
	    Simple_name { sn_name = name ;
			  sn_text = f_desc name ;
			  sn_type = Odoc_env.subst_type env pat.pat_type
			} 
	      
	| Typedtree.Tpat_alias (pat, _) ->
	    iter_pattern pat

	| Typedtree.Tpat_tuple patlist ->
	    Tuple
	      (List.map iter_pattern patlist,
	       Odoc_env.subst_type env pat.pat_type)
	      
	| Typedtree.Tpat_construct (cons_desc, _) when 
	    (* we give a name to the parameter only if it unit *)
	    (match cons_desc.cstr_res.desc with
	      Tconstr (p, _, _) ->
		Path.same p Predef.path_unit 
	    | _ ->
		false)
	  ->
	    (* a () argument, it never has description *)
	    Simple_name { sn_name = "()" ;
			  sn_text = None ;
			  sn_type = Odoc_env.subst_type env pat.pat_type
			} 

	| _ ->
            (* implicit pattern matching -> anonymous parameter *)
	    Simple_name { sn_name = "()" ;
			  sn_text = None ;
			  sn_type = Odoc_env.subst_type env pat.pat_type
			} 
      in
      iter_pattern pat 

    (** Analysis of the parameter of a function. Return a list of t_parameter created from
       the (pattern, expression) structures encountered. *)
    let rec tt_analyse_function_parameters env current_comment_opt pat_exp_list =
      match pat_exp_list with
	[] ->
	  (* This case means we have a 'function' without pattern, that's impossible *)
	  raise (Failure "tt_analyse_function_parameters: 'function' without pattern")

      |	(pattern_param, exp) :: second_ele :: q ->
          (* implicit pattern matching -> anonymous parameter and no more parameter *)
	  (* A VOIR : le label ? *)
	  let parameter = (Odoc_parameter.Tuple ([], Odoc_env.subst_type env pattern_param.pat_type), "") in
	  [ parameter ]

      | (pattern_param, func_body) :: [] ->
	  let parameter = 
	    (tt_param_info_from_pattern 
	       env
	       (Odoc_parameter.desc_from_info_opt current_comment_opt) 
	       pattern_param,
	     "") (* A VOIR : le label ? *)
	  in
         (* For optional parameters with a default value, a special treatment is required *)
         (* we look if the name of the parameter we just add is "*opt*", which means
	    that there is a let param_name = ... in ... just right now *)
	  let (p, next_exp) = 
	    match parameter with
	      (Simple_name { sn_name = "*opt*" }, label) ->
		(
		 (
		  match func_body.exp_desc with
		    Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, func_body2) ->
		      let name = Name.from_ident id in
		      let new_param = 
			(Simple_name { sn_name = name ;
				       sn_text = Odoc_parameter.desc_from_info_opt current_comment_opt name ;
				       sn_type = Odoc_env.subst_type env exp.exp_type
				     },
			 label)
		      in
		      (new_param, func_body2)
		  | _ ->
		      print_DEBUG3 "Pas le bon filtre pour le paramtre optionnel avec valeur par dfaut.";
		      (parameter, func_body)
		 )
		)
	    | _ ->
		(parameter, func_body)
	  in
         (* continue if the body is still a function *)
	  match next_exp.exp_desc with
	    Texp_function (pat_exp_list, _) ->
	      p :: (tt_analyse_function_parameters env current_comment_opt pat_exp_list)
	  | _ ->
              (* something else ; no more parameter *)
	      [ p ]

     (** Analysis of a Tstr_value from the typedtree. Create and return a list of [t_value].
	@raise Failure if an error occurs.*)
     let tt_analyse_value env current_module_name comment_opt loc pat_exp rec_flag =
       let (pat, exp) = pat_exp in
       match (pat.pat_desc, exp.exp_desc) with
	 (Typedtree.Tpat_var ident, Typedtree.Texp_function (pat_exp_list2, partial)) ->
           (* a new function is defined *)
	   let name_pre = Name.from_ident ident in
	   let name = Name.parens_if_infix name_pre in
	   let complete_name = Name.concat current_module_name name in
 	   (* create the value *)
	   let new_value = {
	     val_name = complete_name ;
	     val_info = comment_opt ;
	     val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ;
	     val_recursive = rec_flag = Asttypes.Recursive ;
	     val_parameters = tt_analyse_function_parameters env comment_opt pat_exp_list2 ;
	     val_code = Some (get_string_of_file loc.Location.loc_start loc.Location.loc_end) ;
	     val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; loc_inter = None } ;
	   }	
	   in
	   [ new_value ]
	     
       | (Typedtree.Tpat_var ident, _) ->
	   (* a new value is defined *)	    
	   let name_pre = Name.from_ident ident in
	   let name = Name.parens_if_infix name_pre in
	   let complete_name = Name.concat current_module_name name in
	   let new_value = {
	     val_name = complete_name ;
	     val_info = comment_opt ;
	     val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ;
	     val_recursive = rec_flag = Asttypes.Recursive ;
	     val_parameters = [] ;
	     val_code = Some (get_string_of_file loc.Location.loc_start loc.Location.loc_end) ;
	     val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; loc_inter = None } ;
	   }	
	   in
	   [ new_value ]
	     
       | (Typedtree.Tpat_tuple lpat, _) ->
	   (* new identifiers are defined *)
	   (* A VOIR : by now we don't accept to have global variables defined in tuples *)
	   []
	     
       | _ ->
	   (* something else, we don't care ? A VOIR *)
	   []

    (** This function converts a Types.type_kind into a Odoc_type.type_kind,
       by analysing the comment of each constructor/field, if any.
       @param pos_start is the start position of the type definition.
       @param pos_end is the end position of the type definition.
       @param pos_limit is the position of the last character which can be
       used for a comment, for the variant types, where [pos_end] is not enough
       since we can have comments after this position.
       @return the type kind and the position of the last used character,
       that is the end position of the last character of the comment
       for the last constructor, if the type is a variant. If the type is
       not a variant, then the last position is the [pos_end] parameter.
    *)
    let tt_get_type_kind env pos_start pos_end pos_limit type_kind =
      match type_kind with
	Types.Type_abstract ->
	  (Odoc_type.Type_abstract, pos_end)

      | Types.Type_variant l (*(string * type_expr list) list*) ->
	  let rec f acc last_pos l =
	    match l with
	      [] ->
		(acc, last_pos)
	    | (constructor_name, type_expr_list) :: q ->
                (* we don't have location info, so we try to
		   get it by searching for regexp "constructor_name(blank)*(of)?" from the
		   last location. *)
		let loc_start = 
		  try Str.search_forward (Str.regexp (constructor_name^blank^"*\\(of\\)?")) !file last_pos
		  with
		    Not_found -> 
		      print_DEBUG3 (constructor_name^blank^"*\\(of\\)? n'a rien donn.");
		      last_pos
		in
		let loc_end =
		  match q with
		    [] -> pos_limit 
		  | (constructor_name2, type_expr_list2) :: _ ->
		      try Str.search_forward (Str.regexp ("|"^blank^"*"^constructor_name2^blank^"*\\(of\\)?")) !file loc_start
		      with 
			Not_found -> 
			  print_DEBUG3 (blank^"+|"^constructor_name2^blank^"*\\(of\\)? n'a rien donn.");
			  loc_start
		in
                (* get the comment *)
		let s = get_string_of_file loc_start loc_end in
		let (len, info_opt) = My_ir.just_after_special !file_name  s in
		let new_acc = 
		  acc @ [
			{
			  vc_name = constructor_name ;
			  vc_args = List.map (Odoc_env.subst_type env) type_expr_list ;
			  vc_text = 
			  (match info_opt with 
			    None -> 
			     print_DEBUG3 ("Pas de description pour le constructeur "^constructor_name);
			      None
			  | Some d ->
			      d.Odoc_types.i_desc)
			} 
		      ]
		in
		f new_acc (loc_start + len) q
	  in
	  let (l_cons, new_last_pos) = f [] pos_start l in
	  (Odoc_type.Type_variant l_cons, new_last_pos)

      | Types.Type_record (l, _) ->
          (*(string * mutable_flag * type_expr) list * record_representation *)
	  let rec f acc last_pos l =
	    match l with
	      [] ->
		acc
	    | (field_name, mutable_flag, type_expr) :: q ->
                (* we don't have location info, so we try to
		get it by searching for regexp "(mutable)?blank*field_name(blank)*:" from the
		last location. *)
		let loc_start = 
		  (
		   let regexp = "\\(mutable\\)?"^blank^"*"^field_name^blank^"*:" in
		   try 
		     Str.search_forward (Str.regexp regexp) !file last_pos
		   with Not_found -> 
		     print_DEBUG3 (regexp^" n'a rien donn.");
		     last_pos
		  ) 
		in
		let loc_end = 
		  match q with
		    [] -> pos_end
		  | (field_name2, mutable_flag2, type_expr2) :: _ ->
		      let regexp = "\\(mutable\\)?"^blank^"*"^field_name2^blank^"*:" in
		      try 
			Str.search_forward (Str.regexp regexp) !file loc_start
		      with Not_found -> 
			print_DEBUG3 (regexp^" n'a rien donn.");
			loc_start
		in
                (* get the comment *)
		let s = get_string_of_file loc_start loc_end in
		let (len, info_opt) = My_ir.just_after_special !file_name  s in
		let new_acc = 
		  acc @ [
			{
			  rf_name = field_name ;
			  rf_mutable = mutable_flag = Mutable ;
			  rf_type = Odoc_env.subst_type env type_expr ; 
			  rf_text = 
			      (match info_opt with 
				None -> 
				  print_DEBUG3 ("Pas de description pour le champ "^field_name);
				  None
			      | Some d ->
				  d.Odoc_types.i_desc)
			} 
		      ]
		in
		f new_acc (loc_start + len) q
	  in
	  (Odoc_type.Type_record (f [] pos_start l), pos_end)


    (** This function takes a Typedtree.class_expr and returns a string which can stand for the class name.
       The name can be "object ... end" if the class expression is not an ident or a class constraint or a class apply. *)
    let rec tt_name_of_class_expr clexp =
      match clexp.Typedtree.cl_desc with
	Typedtree.Tclass_ident p -> Name.from_path p
      |	Typedtree.Tclass_constraint (class_expr, _, _, _)
      |	Typedtree.Tclass_apply (class_expr, _) -> tt_name_of_class_expr class_expr
(*
      |	Typedtree.Tclass_fun (_, _, class_expr, _) -> tt_name_of_class_expr class_expr
      |	Typedtree.Tclass_let (_,_,_, class_expr) -> tt_name_of_class_expr class_expr
*)
      |	 _ -> Odoc_messages.object_end

    (** Analysis of a method expression to get the method parameters. 
       @param first indicates if we're analysing the method for
       the first time ; in that case we must not keep the first parameter,
       which is "self-*", the object itself.
    *)
    let rec tt_analyse_method_expression env current_method_name comment_opt ?(first=true) exp =
      match exp.Typedtree.exp_desc with
	Typedtree.Texp_function (pat_exp_list, _) ->
	  (
	   match pat_exp_list with
	     [] ->
	       (* it is not a function since there are no parameters *)
	       (* we can't get here normally *)
	       raise (Failure (Odoc_messages.bad_tree^" "^(Odoc_messages.method_without_param current_method_name)))
	   | l ->
	       match l with
		 [] ->
		   (* cas impossible, on l'a filtr avant *)
		   assert false
	       | (pattern_param, exp) :: second_ele :: q ->
                   (* implicit pattern matching -> anonymous parameter *)
		   (* Note : We can't match this pattern if it is the first call to the function. *)
		   let new_param = 
		     (Simple_name { sn_name = "??" ; sn_text =  None; 
				    sn_type = Odoc_env.subst_type env pattern_param.Typedtree.pat_type },
		      "") (* A VOIR : le label ? *)
		   in
		   [ new_param ]
		     
	       | (pattern_param, body) :: [] ->
		   (* if this is the first call to the function, this is the first parameter and we skip it *)
		   if not first then
		     (
		      let parameter = 
			(tt_param_info_from_pattern
			   env
			   (Odoc_parameter.desc_from_info_opt comment_opt) 
			   pattern_param ,
			 "") (* A VOIR : le label ? *)
		      in
                      (* For optional parameters with a default value, a special treatment is required. *)
                      (* We look if the name of the parameter we just add is "*opt*", which means
			 that there is a let param_name = ... in ... just right now. *)
		      let (current_param, next_exp) = 
			match parameter with
			  (Simple_name { sn_name = "*opt*"}, label) ->
			    (
			     (
			      match body.exp_desc with
				Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, body2) ->
				  let name = Name.from_ident id in
				  let new_param = 
				    (Simple_name { sn_name = name ;
						   sn_text = Odoc_parameter.desc_from_info_opt comment_opt name ;
						   sn_type = Odoc_env.subst_type env exp.Typedtree.exp_type ; 
						 },
				     label)
				  in
				  (new_param, body2)
			      | _ ->
				  print_DEBUG3 "Pas le bon filtre pour le paramtre optionnel avec valeur par dfaut.";
				  (parameter, body)
			     )
			    )
			| _ ->
  	                    (* no *opt* parameter, we add the parameter then continue *)
			    (parameter, body)
		      in
		      current_param :: (tt_analyse_method_expression env current_method_name comment_opt ~first: false next_exp)
		     )
		   else
		     tt_analyse_method_expression env current_method_name comment_opt ~first: false body
	  )
      | _ ->
	  (* no more parameter *)
	  []

    (** Analysis of a [Parsetree.class_struture] and a [Typedtree.class_structure] to get a couple 
       (inherited classes, class elements). *)
    let analyse_class_structure env current_class_name tt_class_sig last_pos pos_limit p_cls tt_cls =
      let rec iter acc_inher acc_fields last_pos = function
	| [] -> 
	    let s = get_string_of_file last_pos pos_limit in
	    let (_, ele_coms) = My_ir.all_special !file_name s in
	    let ele_comments =
	      List.fold_left
		(fun acc -> fun sc ->
		  match sc.Odoc_types.i_desc with
		    None ->
		      acc
		  | Some t ->
		      acc @ [Class_comment t])
		[]
		ele_coms
	    in
	    (acc_inher, acc_fields @ ele_comments)

	| (Parsetree.Pcf_inher (p_clexp, _)) :: q  ->
	    let tt_clexp =
	      let n = List.length acc_inher in
	      try Typedtree_search.get_nth_inherit_class_expr tt_cls n
	      with Not_found -> raise (Failure (Odoc_messages.inherit_classexp_not_found_in_typedtree n))
	    in
	    let (info_opt, ele_comments) = get_comments_in_class last_pos p_clexp.Parsetree.pcl_loc.Location.loc_start in
	    let text_opt = match info_opt with None -> None | Some i -> i.Odoc_types.i_desc in
	    let name = tt_name_of_class_expr tt_clexp in
	    let inher = { ic_name = Odoc_env.full_class_or_class_type_name env name ; ic_class = None ; ic_text = text_opt }  in
	    iter (acc_inher @ [ inher ]) (acc_fields @ ele_comments)
	      p_clexp.Parsetree.pcl_loc.Location.loc_end
	      q

	| (Parsetree.Pcf_val (label, mutable_flag, expression, loc)) :: q ->
	    let complete_name = Name.concat current_class_name label in
	    let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start in
	    let type_exp =
	      try Typedtree_search.search_attribute_type tt_cls label
	      with Not_found -> raise (Failure (Odoc_messages.attribute_not_found_in_typedtree complete_name))
	    in
	    let att =
	      {
		att_value = { val_name = complete_name ; 
			      val_info = info_opt ;
			      val_type = Odoc_env.subst_type env type_exp ;
			      val_recursive = false ;
			      val_parameters = [] ; 
			      val_code = Some (get_string_of_file loc.Location.loc_start loc.Location.loc_end) ;
			      val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; loc_inter = None } ;
			    } ;
		att_mutable = mutable_flag = Asttypes.Mutable ;
	      }	
	    in
	    iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end q
      
	| (Parsetree.Pcf_virt  (label, private_flag, _, loc)) :: q ->
	    let complete_name = Name.concat current_class_name label in
	    let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start in
	    let met_type = 
	      try Odoc_sig.Signature_search.search_method_type label tt_class_sig 
	      with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label))
	    in
	    let real_type =
	      match met_type.Types.desc with
		Tarrow (_, _, t, _) ->
		  t
	      |  _ ->
     	        (* ?!? : not an arrow type ! return the original type *)
		  met_type
	    in
	    let met = 
	      {
		met_value = { val_name = complete_name ;
			      val_info = info_opt ;
			      val_type = Odoc_env.subst_type env real_type ;
			      val_recursive = false ;
			      val_parameters = [] ;
			      val_code = Some (get_string_of_file loc.Location.loc_start loc.Location.loc_end) ;
			      val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; loc_inter = None } ;
			    } ;
		met_private = private_flag = Asttypes.Private ;
		met_virtual = true ;
	      }	
	    in
      	    (* update the parameter description *)
	    Odoc_value.update_value_parameters_text met.met_value;

	    iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end q

	| (Parsetree.Pcf_meth  (label, private_flag, _, loc)) :: q ->
	    let complete_name = Name.concat current_class_name label in
	    let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start in
	    let exp = 
	      try Typedtree_search.search_method_expression tt_cls label
	      with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name))
	    in
	    let real_type =
	      match exp.exp_type.desc with
		Tarrow (_, _, t,_) ->
		  t
	      |  _ ->
     	        (* ?!? : not an arrow type ! return the original type *)
		  exp.Typedtree.exp_type
	    in
	    let met = 
	      {
		met_value = { val_name = complete_name ;
			      val_info = info_opt ;
			      val_type = Odoc_env.subst_type env real_type ;
			      val_recursive = false ;
			      val_parameters = tt_analyse_method_expression env complete_name info_opt exp ;
			      val_code = Some (get_string_of_file loc.Location.loc_start loc.Location.loc_end) ;
			      val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start) ; loc_inter = None } ;
			    } ;
		met_private = private_flag = Asttypes.Private ;
		met_virtual = false ;
	      }	
	    in
      	    (* update the parameter description *)
	    Odoc_value.update_value_parameters_text met.met_value;

	    iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end q
	    
	| Parsetree.Pcf_cstr (_, _, loc) :: q ->
	    (* don't give a $*%@ ! *)
	    iter acc_inher acc_fields loc.Location.loc_end q

	| Parsetree.Pcf_let (_, _, loc) :: q ->
	    (* don't give a $*%@ ! *)
	    iter acc_inher acc_fields loc.Location.loc_end q

	| (Parsetree.Pcf_init exp) :: q ->
	    iter acc_inher acc_fields exp.Parsetree.pexp_loc.Location.loc_end q
      in
      iter [] [] last_pos (snd p_cls)
	      
    (** Analysis of a [Parsetree.class_expr] and a [Typedtree.class_expr] to get a a couple (class parameters, class kind). *)
    let rec analyse_class_kind env current_class_name comment_opt last_pos p_class_expr tt_class_exp =
      match (p_class_expr.Parsetree.pcl_desc, tt_class_exp.Typedtree.cl_desc) with
	(Parsetree.Pcl_constr (lid, _), tt_class_exp_desc ) -> 
	  let name = 
	    match tt_class_exp_desc with
	      Typedtree.Tclass_ident p -> Name.from_path p 
	    | _ ->
		(* we try to get the name from the environment. *)
                (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( mme quand on a class tutu = toto *)
		Name.from_longident lid
	  in
	  (* On n'a pas ici les paramtres de type sous forme de Types.type_expr,
	     par contre on peut les trouver dans le class_type *)
	  let params = 
	    match tt_class_exp.Typedtree.cl_type with
	      Types.Tcty_constr (p2, type_exp_list, cltyp) ->
		(* cltyp is the class type for [type_exp_list] p *)
		type_exp_list
	    | _ ->
		[]
	  in
	  ([], 
	   Class_constr
	     {
	       cco_name = Odoc_env.full_class_name env name ;
	       cco_class = None ;
	       cco_type_parameters = List.map (Odoc_env.subst_type env) params ; 
	     } )

      | (Parsetree.Pcl_structure p_class_structure, Typedtree.Tclass_structure tt_class_structure) ->
	  (* we need the class signature to get the type of methods in analyse_class_structure *)
	  let tt_class_sig = 
	    match tt_class_exp.Typedtree.cl_type with
	      Types.Tcty_signature class_sig -> class_sig
	    | _ -> raise (Failure "analyse_class_kind: no class signature for a class structure.")
	  in
	  let (inherited_classes, class_elements) = analyse_class_structure 
	      env
	      current_class_name 
	      tt_class_sig
	      last_pos
	      p_class_expr.Parsetree.pcl_loc.Location.loc_end
	      p_class_structure
	      tt_class_structure
	  in
	  ([],
	   Class_structure (inherited_classes, class_elements) )
	    
      | (Parsetree.Pcl_fun (label, expression_opt, pattern, p_class_expr2),
	 Typedtree.Tclass_fun (pat, ident_exp_list, tt_class_expr2, partial)) ->
	   (* we check that this is not an optional parameter with
	      a default value. In this case, we look for the good parameter pattern *)
	   let (parameter, next_tt_class_exp) =
	     match pat.Typedtree.pat_desc with
	       Typedtree.Tpat_var ident when Name.from_ident ident = "*opt*" ->
		 (
		  (* there must be a Tclass_let just after *)
		  match tt_class_expr2.Typedtree.cl_desc with
		    Typedtree.Tclass_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, _, tt_class_expr3) ->
		      let name = Name.from_ident id in
		      let new_param = 
{'fraction_non_alphanumeric': 0.09361235397552185, 'fraction_numerical': 0.001984714218562301, 'mean_word_length': 2.3968066232998226, 'pattern_counts': {'":': 0, '<': 7, '<?xml version=': 0, '>': 295, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 12, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1264352', 'n_tokens_mistral': 20154, 'n_tokens_neox': 18232, 'n_words': 5189}