diff options
Diffstat (limited to 'ocamldoc/odoc_merge.ml')
| -rw-r--r-- | ocamldoc/odoc_merge.ml | 953 |
1 files changed, 0 insertions, 953 deletions
diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml deleted file mode 100644 index ae1d6dcf43..0000000000 --- a/ocamldoc/odoc_merge.ml +++ /dev/null @@ -1,953 +0,0 @@ -(***********************************************************************) -(* 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. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** 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 } ; - mli.ty_code <- (match mli.ty_code with None -> ml.ty_code | _ -> mli.ty_code) ; - - 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 } ; - ex.ex_code <- (match ex.ex_code with None -> ex2.ex_code | _ -> ex.ex_code) ; - 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 ; - - let code = - if !Odoc_args.keep_code then - match mli.m_code, ml.m_code with - Some s, _ -> Some s - | _, Some s -> Some s - | _ -> None - else - None - in - mli.m_code <- code; - - (* 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 } ; - ex.ex_code <- (match ex.ex_code with None -> ex2.ex_code | _ -> ex.ex_code) ; - 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 - -(* eof $Id$ *) |