diff options
Diffstat (limited to 'ocamldoc/odoc_merge.ml')
| -rw-r--r-- | ocamldoc/odoc_merge.ml | 935 |
1 files changed, 935 insertions, 0 deletions
diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml new file mode 100644 index 000000000..aa01c77d3 --- /dev/null +++ b/ocamldoc/odoc_merge.ml @@ -0,0 +1,935 @@ +(***********************************************************************) +(* OCamldoc *) +(* *) +(* Maxence Guesdon, projet Cristal, 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. *) +(* *) +(***********************************************************************) + + +(** Merge of information from [.ml] and [.mli] for a module.*) + +open Odoc_types + +module Name = Odoc_name +open Odoc_parameter +open Odoc_value +open Odoc_type +open Odoc_exception +open Odoc_class +open Odoc_module + +(** Merge two Odoctypes.info struture, completing the information of + the first one with the information in the second one. + The merge treatment depends on a given merge_option list. + @return the new info structure.*) +let merge_info merge_options (m1 : info) (m2 : info) = + let new_desc_opt = + match m1.i_desc, m2.i_desc with + None, None -> None + | None, Some d + | Some d, None -> Some d + | Some d1, Some d2 -> + if List.mem Merge_description merge_options then + Some (d1 @ (Newline :: d2)) + else + Some d1 + in + let new_authors = + match m1.i_authors, m2.i_authors with + [], [] -> [] + | l, [] + | [], l -> l + | l1, l2 -> + if List.mem Merge_author merge_options then + l1 @ l2 + else + l1 + in + let new_version = + match m1.i_version , m2.i_version with + None, None -> None + | Some v, None + | None, Some v -> Some v + | Some v1, Some v2 -> + if List.mem Merge_version merge_options then + Some (v1^" "^v2) + else + Some v1 + in + let new_sees = + match m1.i_sees, m2.i_sees with + [], [] -> [] + | l, [] + | [], l -> l + | l1, l2 -> + if List.mem Merge_see merge_options then + l1 @ l2 + else + l1 + in + let new_since = + match m1.i_since, m2.i_since with + None, None -> None + | Some v, None + | None, Some v -> Some v + | Some v1, Some v2 -> + if List.mem Merge_since merge_options then + Some (v1^" "^v2) + else + Some v1 + in + let new_dep = + match m1.i_deprecated, m2.i_deprecated with + None, None -> None + | None, Some t + | Some t, None -> Some t + | Some t1, Some t2 -> + if List.mem Merge_deprecated merge_options then + Some (t1 @ (Newline :: t2)) + else + Some t1 + in + let new_params = + match m1.i_params, m2.i_params with + [], [] -> [] + | l, [] + | [], l -> l + | l1, l2 -> + if List.mem Merge_param merge_options then + ( + let l_in_m1_and_m2, l_in_m2_only = List.partition + (fun (param2, _) -> List.mem_assoc param2 l1) + l2 + in + let rec iter = function + [] -> [] + | (param2, desc2) :: q -> + let desc1 = List.assoc param2 l1 in + (param2, desc1 @ (Newline :: desc2)) :: (iter q) + in + let l1_completed = iter l_in_m1_and_m2 in + l1_completed @ l_in_m2_only + ) + else + l1 + in + let new_raised_exceptions = + match m1.i_raised_exceptions, m2.i_raised_exceptions with + [], [] -> [] + | l, [] + | [], l -> l + | l1, l2 -> + if List.mem Merge_raised_exception merge_options then + ( + let l_in_m1_and_m2, l_in_m2_only = List.partition + (fun (exc2, _) -> List.mem_assoc exc2 l1) + l2 + in + let rec iter = function + [] -> [] + | (exc2, desc2) :: q -> + let desc1 = List.assoc exc2 l1 in + (exc2, desc1 @ (Newline :: desc2)) :: (iter q) + in + let l1_completed = iter l_in_m1_and_m2 in + l1_completed @ l_in_m2_only + ) + else + l1 + in + let new_rv = + match m1.i_return_value, m2.i_return_value with + None, None -> None + | None, Some t + | Some t, None -> Some t + | Some t1, Some t2 -> + if List.mem Merge_return_value merge_options then + Some (t1 @ (Newline :: t2)) + else + Some t1 + in + let new_custom = + match m1.i_custom, m2.i_custom with + [], [] -> [] + | [], l + | l, [] -> l + | l1, l2 -> + if List.mem Merge_custom merge_options then + l1 @ l2 + else + l1 + in + { + Odoc_types.i_desc = new_desc_opt ; + Odoc_types.i_authors = new_authors ; + Odoc_types.i_version = new_version ; + Odoc_types.i_sees = new_sees ; + Odoc_types.i_since = new_since ; + Odoc_types.i_deprecated = new_dep ; + Odoc_types.i_params = new_params ; + Odoc_types.i_raised_exceptions = new_raised_exceptions ; + Odoc_types.i_return_value = new_rv ; + Odoc_types.i_custom = new_custom ; + } + +(** Merge of two optional info structures. *) +let merge_info_opt merge_options mli_opt ml_opt = + match mli_opt, ml_opt with + None, Some i -> Some i + | Some i, None -> Some i + | None, None -> None + | Some i1, Some i2 -> Some (merge_info merge_options i1 i2) + +(** merge of two t_type, one for a .mli, another for the .ml. + The .mli type is completed with the information in the .ml type. *) +let merge_types merge_options mli ml = + mli.ty_info <- merge_info_opt merge_options mli.ty_info ml.ty_info; + mli.ty_loc <- { mli.ty_loc with loc_impl = ml.ty_loc.loc_impl } ; + match mli.ty_kind, ml.ty_kind with + Type_abstract, _ -> + () + + | Type_variant l1, Type_variant l2 -> + let f cons = + try + let cons2 = List.find + (fun c2 -> c2.vc_name = cons.vc_name) + l2 + in + let new_desc = + match cons.vc_text, cons2.vc_text with + None, None -> None + | Some d, None + | None, Some d -> Some d + | Some d1, Some d2 -> + if List.mem Merge_description merge_options then + Some (d1 @ d2) + else + Some d1 + in + cons.vc_text <- new_desc + with + Not_found -> + if !Odoc_args.inverse_merge_ml_mli then + () + else + raise (Failure (Odoc_messages.different_types mli.ty_name)) + in + List.iter f l1 + + | Type_record l1, Type_record l2 -> + let f record = + try + let record2= List.find + (fun r -> r.rf_name = record.rf_name) + l2 + in + let new_desc = + match record.rf_text, record2.rf_text with + None, None -> None + | Some d, None + | None, Some d -> Some d + | Some d1, Some d2 -> + if List.mem Merge_description merge_options then + Some (d1 @ d2) + else + Some d1 + in + record.rf_text <- new_desc + with + Not_found -> + if !Odoc_args.inverse_merge_ml_mli then + () + else + raise (Failure (Odoc_messages.different_types mli.ty_name)) + in + List.iter f l1 + + | _ -> + if !Odoc_args.inverse_merge_ml_mli then + () + else + raise (Failure (Odoc_messages.different_types mli.ty_name)) + +(** Merge of two param_info, one from a .mli, one from a .ml. + The text fields are not handled but will be recreated from the + i_params field of the info structure. + Here, if a parameter in the .mli has no name, we take the one + from the .ml. When two parameters have two different forms, + we take the one from the .mli. *) +let rec merge_param_info pi_mli pi_ml = + match (pi_mli, pi_ml) with + (Simple_name sn_mli, Simple_name sn_ml) -> + if sn_mli.sn_name = "" then + Simple_name { sn_mli with sn_name = sn_ml.sn_name } + else + pi_mli + | (Simple_name _, Tuple _) -> + pi_mli + | (Tuple (_, t_mli), Simple_name sn_ml) -> + (* if we're here, then the tuple in the .mli has no parameter names ; + then we take the name of the parameter of the .ml and the type of the .mli. *) + Simple_name { sn_ml with sn_type = t_mli } + + | (Tuple (l_mli, t_mli), Tuple (l_ml, _)) -> + (* if the two tuples have different lengths + (which should not occurs), we return the pi_mli, + without further investigation.*) + if (List.length l_mli) <> (List.length l_ml) then + pi_mli + else + let new_l = List.map2 merge_param_info l_mli l_ml in + Tuple (new_l, t_mli) + +(** Merge of the parameters of two functions/methods/classes, one for a .mli, another for a .ml. + The prameters in the .mli are completed by the name in the .ml.*) +let rec merge_parameters param_mli param_ml = + match (param_mli, param_ml) with + ([], []) -> [] + | (l, []) | ([], l) -> l + | (pi_mli :: li, pi_ml :: l) -> + (merge_param_info pi_mli pi_ml) :: merge_parameters li l + +(** Merge of two t_class, one for a .mli, another for the .ml. + The .mli class is completed with the information in the .ml class. *) +let merge_classes merge_options mli ml = + mli.cl_info <- merge_info_opt merge_options mli.cl_info ml.cl_info; + mli.cl_loc <- { mli.cl_loc with loc_impl = ml.cl_loc.loc_impl } ; + mli.cl_parameters <- merge_parameters mli.cl_parameters ml.cl_parameters; + + (* we must reassociate comments in @param to the the corresponding + parameters because the associated comment of a parameter may have been changed y the merge.*) + Odoc_class.class_update_parameters_text mli; + + (* merge values *) + List.iter + (fun a -> + try + let _ = List.find + (fun ele -> + match ele with + Class_attribute a2 -> + if a2.att_value.val_name = a.att_value.val_name then + ( + a.att_value.val_info <- merge_info_opt merge_options + a.att_value.val_info a2.att_value.val_info; + a.att_value.val_loc <- { a.att_value.val_loc with loc_impl = a2.att_value.val_loc.loc_impl } ; + if !Odoc_args.keep_code then + a.att_value.val_code <- a2.att_value.val_code; + true + ) + else + false + | _ -> + false + ) + (* we look for the last attribute with this name defined in the implementation *) + (List.rev (Odoc_class.class_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_class.class_attributes mli); + (* merge methods *) + List.iter + (fun m -> + try + let _ = List.find + (fun ele -> + match ele with + Class_method m2 -> + if m2.met_value.val_name = m.met_value.val_name then + ( + m.met_value.val_info <- merge_info_opt + merge_options m.met_value.val_info m2.met_value.val_info; + m.met_value.val_loc <- { m.met_value.val_loc with loc_impl = m2.met_value.val_loc.loc_impl } ; + (* merge the parameter names *) + m.met_value.val_parameters <- (merge_parameters + m.met_value.val_parameters + m2.met_value.val_parameters) ; + (* we must reassociate comments in @param to the corresponding + parameters because the associated comment of a parameter may have been changed by the merge.*) + Odoc_value.update_value_parameters_text m.met_value; + + if !Odoc_args.keep_code then + m.met_value.val_code <- m2.met_value.val_code; + + true + ) + else + false + | _ -> + false + ) + (* we look for the last method with this name defined in the implementation *) + (List.rev (Odoc_class.class_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_class.class_methods mli) + +(** merge of two t_class_type, one for a .mli, another for the .ml. + The .mli class is completed with the information in the .ml class. *) +let merge_class_types merge_options mli ml = + mli.clt_info <- merge_info_opt merge_options mli.clt_info ml.clt_info; + mli.clt_loc <- { mli.clt_loc with loc_impl = ml.clt_loc.loc_impl } ; + (* merge values *) + List.iter + (fun a -> + try + let _ = List.find + (fun ele -> + match ele with + Class_attribute a2 -> + if a2.att_value.val_name = a.att_value.val_name then + ( + a.att_value.val_info <- merge_info_opt merge_options + a.att_value.val_info a2.att_value.val_info; + a.att_value.val_loc <- { a.att_value.val_loc with loc_impl = a2.att_value.val_loc.loc_impl } ; + if !Odoc_args.keep_code then + a.att_value.val_code <- a2.att_value.val_code; + + true + ) + else + false + | _ -> + false + ) + (* we look for the last attribute with this name defined in the implementation *) + (List.rev (Odoc_class.class_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_class.class_type_attributes mli); + (* merge methods *) + List.iter + (fun m -> + try + let _ = List.find + (fun ele -> + match ele with + Class_method m2 -> + if m2.met_value.val_name = m.met_value.val_name then + ( + m.met_value.val_info <- merge_info_opt + merge_options m.met_value.val_info m2.met_value.val_info; + m.met_value.val_loc <- { m.met_value.val_loc with loc_impl = m2.met_value.val_loc.loc_impl } ; + m.met_value.val_parameters <- (merge_parameters + m.met_value.val_parameters + m2.met_value.val_parameters) ; + (* we must reassociate comments in @param to the the corresponding + parameters because the associated comment of a parameter may have been changed y the merge.*) + Odoc_value.update_value_parameters_text m.met_value; + + if !Odoc_args.keep_code then + m.met_value.val_code <- m2.met_value.val_code; + + true + ) + else + false + | _ -> + false + ) + (* we look for the last method with this name defined in the implementation *) + (List.rev (Odoc_class.class_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_class.class_type_methods mli) + + +(** merge of two t_module_type, one for a .mli, another for the .ml. + The .mli module is completed with the information in the .ml module. *) +let rec merge_module_types merge_options mli ml = + mli.mt_info <- merge_info_opt merge_options mli.mt_info ml.mt_info; + mli.mt_loc <- { mli.mt_loc with loc_impl = ml.mt_loc.loc_impl } ; + (* merge exceptions *) + List.iter + (fun ex -> + try + let _ = List.find + (fun ele -> + match ele with + Element_exception ex2 -> + if ex2.ex_name = ex.ex_name then + ( + ex.ex_info <- merge_info_opt merge_options ex.ex_info ex2.ex_info; + ex.ex_loc <- { ex.ex_loc with loc_impl = ex2.ex_loc.loc_impl } ; + true + ) + else + false + | _ -> + false + ) + (* we look for the last exception with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_exceptions mli); + (* merge types *) + List.iter + (fun ty -> + try + let _ = List.find + (fun ele -> + match ele with + Element_type ty2 -> + if ty2.ty_name = ty.ty_name then + ( + merge_types merge_options ty ty2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last type with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_types mli); + (* merge submodules *) + List.iter + (fun m -> + try + let _ = List.find + (fun ele -> + match ele with + Element_module m2 -> + if m2.m_name = m.m_name then + ( + merge_modules merge_options m m2 ; +(* + m.m_info <- merge_info_opt merge_options m.m_info m2.m_info; + m.m_loc <- { m.m_loc with loc_impl = m2.m_loc.loc_impl } ; +*) + true + ) + else + false + | _ -> + false + ) + (* we look for the last module with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_modules mli); + + (* merge module types *) + List.iter + (fun m -> + try + let _ = List.find + (fun ele -> + match ele with + Element_module_type m2 -> + if m2.mt_name = m.mt_name then + ( + merge_module_types merge_options m m2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last module with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_module_types mli); + + (* A VOIR : merge included modules ? *) + + (* merge values *) + List.iter + (fun v -> + try + let _ = List.find + (fun ele -> + match ele with + Element_value v2 -> + if v2.val_name = v.val_name then + ( + v.val_info <- merge_info_opt merge_options v.val_info v2.val_info ; + v.val_loc <- { v.val_loc with loc_impl = v2.val_loc.loc_impl } ; + (* in the .mli we don't know any parameters so we add the ones in the .ml *) + v.val_parameters <- (merge_parameters + v.val_parameters + v2.val_parameters) ; + (* we must reassociate comments in @param to the the corresponding + parameters because the associated comment of a parameter may have been changed y the merge.*) + Odoc_value.update_value_parameters_text v; + + if !Odoc_args.keep_code then + v.val_code <- v2.val_code; + + true + ) + else + false + | _ -> + false + ) + (* we look for the last value with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_values mli); + + (* merge classes *) + List.iter + (fun c -> + try + let _ = List.find + (fun ele -> + match ele with + Element_class c2 -> + if c2.cl_name = c.cl_name then + ( + merge_classes merge_options c c2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last value with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_classes mli); + + (* merge class types *) + List.iter + (fun c -> + try + let _ = List.find + (fun ele -> + match ele with + Element_class_type c2 -> + if c2.clt_name = c.clt_name then + ( + merge_class_types merge_options c c2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last value with this name defined in the implementation *) + (List.rev (Odoc_module.module_type_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_type_class_types mli) + +(** merge of two t_module, one for a .mli, another for the .ml. + The .mli module is completed with the information in the .ml module. *) +and merge_modules merge_options mli ml = + mli.m_info <- merge_info_opt merge_options mli.m_info ml.m_info; + mli.m_loc <- { mli.m_loc with loc_impl = ml.m_loc.loc_impl } ; + (* More dependencies in the .ml file. *) + mli.m_top_deps <- ml.m_top_deps ; + (* merge exceptions *) + List.iter + (fun ex -> + try + let _ = List.find + (fun ele -> + match ele with + Element_exception ex2 -> + if ex2.ex_name = ex.ex_name then + ( + ex.ex_info <- merge_info_opt merge_options ex.ex_info ex2.ex_info; + ex.ex_loc <- { ex.ex_loc with loc_impl = ex.ex_loc.loc_impl } ; + true + ) + else + false + | _ -> + false + ) + (* we look for the last exception with this name defined in the implementation *) + (List.rev (Odoc_module.module_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_exceptions mli); + (* merge types *) + List.iter + (fun ty -> + try + let _ = List.find + (fun ele -> + match ele with + Element_type ty2 -> + if ty2.ty_name = ty.ty_name then + ( + merge_types merge_options ty ty2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last type with this name defined in the implementation *) + (List.rev (Odoc_module.module_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_types mli); + (* merge submodules *) + List.iter + (fun m -> + try + let _ = List.find + (fun ele -> + match ele with + Element_module m2 -> + if m2.m_name = m.m_name then + ( + merge_modules merge_options m m2 ; +(* + m.m_info <- merge_info_opt merge_options m.m_info m2.m_info; + m.m_loc <- { m.m_loc with loc_impl = m2.m_loc.loc_impl } ; +*) + true + ) + else + false + | _ -> + false + ) + (* we look for the last module with this name defined in the implementation *) + (List.rev (Odoc_module.module_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_modules mli); + + (* merge module types *) + List.iter + (fun m -> + try + let _ = List.find + (fun ele -> + match ele with + Element_module_type m2 -> + if m2.mt_name = m.mt_name then + ( + merge_module_types merge_options m m2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last module with this name defined in the implementation *) + (List.rev (Odoc_module.module_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_module_types mli); + + (* A VOIR : merge included modules ? *) + + (* merge values *) + List.iter + (fun v -> + try + let _ = List.find + (fun v2 -> + if v2.val_name = v.val_name then + ( + v.val_info <- merge_info_opt merge_options v.val_info v2.val_info ; + v.val_loc <- { v.val_loc with loc_impl = v2.val_loc.loc_impl } ; + (* in the .mli we don't know any parameters so we add the ones in the .ml *) + v.val_parameters <- (merge_parameters + v.val_parameters + v2.val_parameters) ; + (* we must reassociate comments in @param to the the corresponding + parameters because the associated comment of a parameter may have been changed y the merge.*) + Odoc_value.update_value_parameters_text v; + + if !Odoc_args.keep_code then + v.val_code <- v2.val_code; + true + ) + else + false + ) + (* we look for the last value with this name defined in the implementation *) + (List.rev (Odoc_module.module_values ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_values mli); + + (* merge classes *) + List.iter + (fun c -> + try + let _ = List.find + (fun ele -> + match ele with + Element_class c2 -> + if c2.cl_name = c.cl_name then + ( + merge_classes merge_options c c2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last value with this name defined in the implementation *) + (List.rev (Odoc_module.module_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_classes mli); + + (* merge class types *) + List.iter + (fun c -> + try + let _ = List.find + (fun ele -> + match ele with + Element_class_type c2 -> + if c2.clt_name = c.clt_name then + ( + merge_class_types merge_options c c2; + true + ) + else + false + | _ -> + false + ) + (* we look for the last value with this name defined in the implementation *) + (List.rev (Odoc_module.module_elements ml)) + in + () + with + Not_found -> + () + ) + (Odoc_module.module_class_types mli); + + mli + +let merge merge_options modules_list = + let rec iter = function + [] -> [] + | m :: q -> + (* look for another module with the same name *) + let (l_same, l_others) = List.partition + (fun m2 -> m.m_name = m2.m_name) + q + in + match l_same with + [] -> + (* no other module to merge with *) + m :: (iter l_others) + | m2 :: [] -> + ( + (* we can merge m with m2 if there is an implementation + and an interface.*) + let f b = if !Odoc_args.inverse_merge_ml_mli then not b else b in + match f m.m_is_interface, f m2.m_is_interface with + true, false -> (merge_modules merge_options m m2) :: (iter l_others) + | false, true -> (merge_modules merge_options m2 m) :: (iter l_others) + | false, false -> + if !Odoc_args.inverse_merge_ml_mli then + (* two Module.ts for the .mli ! *) + raise (Failure (Odoc_messages.two_interfaces m.m_name)) + else + (* two Module.t for the .ml ! *) + raise (Failure (Odoc_messages.two_implementations m.m_name)) + | true, true -> + if !Odoc_args.inverse_merge_ml_mli then + (* two Module.t for the .ml ! *) + raise (Failure (Odoc_messages.two_implementations m.m_name)) + else + (* two Module.ts for the .mli ! *) + raise (Failure (Odoc_messages.two_interfaces m.m_name)) + ) + | _ -> + (* two many Module.t ! *) + raise (Failure (Odoc_messages.too_many_module_objects m.m_name)) + + in + iter modules_list + |