diff options
Diffstat (limited to 'ocamldoc/odoc_sig.ml')
| -rw-r--r-- | ocamldoc/odoc_sig.ml | 258 |
1 files changed, 212 insertions, 46 deletions
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 627938453..c2d365118 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -24,6 +24,7 @@ module Name = Odoc_name open Odoc_parameter open Odoc_value open Odoc_type +open Odoc_extension open Odoc_exception open Odoc_class open Odoc_module @@ -38,8 +39,7 @@ module Signature_search = | T of string | C of string | CT of string - | E of string - | ER of string + | X of string | P of string type tab = (ele, Types.signature_item) Hashtbl.t @@ -48,8 +48,8 @@ module Signature_search = match signat with Types.Sig_value (ident, _) -> Hashtbl.add table (V (Name.from_ident ident)) signat - | Types.Sig_exception (ident, _) -> - Hashtbl.add table (E (Name.from_ident ident)) signat + | Types.Sig_typext (ident, _, _) -> + Hashtbl.add table (X (Name.from_ident ident)) signat | Types.Sig_type (ident, _, _) -> Hashtbl.add table (T (Name.from_ident ident)) signat | Types.Sig_class (ident, _, _) -> @@ -71,10 +71,9 @@ module Signature_search = | (Types.Sig_value (_, val_desc)) -> val_desc.Types.val_type | _ -> assert false - let search_exception table name = - match Hashtbl.find table (E name) with - | (Types.Sig_exception (_, type_expr_list)) -> - type_expr_list + let search_extension table name = + match Hashtbl.find table (X name) with + | (Types.Sig_typext (_, ext, _)) -> ext | _ -> assert false let search_type table name = @@ -169,10 +168,44 @@ module Analyser = let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options - let name_comment_from_type_kind pos_end pos_limit tk = - match tk with - Parsetree.Ptype_abstract -> - (0, []) + let name_comment_from_type_decl pos_end pos_limit ty_decl = + match ty_decl.Parsetree.ptype_kind with + | Parsetree.Ptype_abstract -> + let open Parsetree in + begin match ty_decl.ptype_manifest with + | None -> (0, []) + | Some core_ty -> + begin match core_ty.ptyp_desc with + | Ptyp_object (fields, _) -> + let rec f = function + | [] -> [] + | ("",_,_) :: _ -> + (* Fields with no name have been eliminated previously. *) + assert false + + | (name, _atts, ct) :: [] -> + let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in + let s = get_string_of_file pos pos_end in + let (_,comment_opt) = My_ir.just_after_special !file_name s in + [name, comment_opt] + | (name, _atts, ct) :: ((name2, _atts2, ct2) as ele2) :: q -> + let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in + let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in + let s = get_string_of_file pos pos2 in + let (_,comment_opt) = My_ir.just_after_special !file_name s in + (name, comment_opt) :: (f (ele2 :: q)) + in + let is_named_field field = + match field with + | ("",_,_) -> false + | _ -> true + in + (0, f @@ List.filter is_named_field fields) + + | _ -> (0, []) + end + end + | Parsetree.Ptype_variant cons_core_type_list_list -> let rec f acc cons_core_type_list_list = let open Parsetree in @@ -187,6 +220,7 @@ module Analyser = let (len, comment_opt) = My_ir.just_after_special !file_name s in (len, acc @ [ (pcd.pcd_name.txt, comment_opt) ]) | pcd :: (pcd2 :: _ as q) -> + (* TODO: support annotations on fields for inline records *) let pos_end_first = pcd.pcd_loc.Location.loc_end.Lexing.pos_cnum in let pos_start_second = pcd2.pcd_loc.Location.loc_start.Lexing.pos_cnum in let s = get_string_of_file pos_end_first pos_start_second in @@ -213,21 +247,58 @@ module Analyser = (name.txt, comment_opt) :: (f (ele2 :: q)) in (0, f name_mutable_type_list) + | Parsetree.Ptype_open -> + (0, []) + + + let manifest_structure env name_comment_list type_expr = + match type_expr.desc with + | Tobject (fields, _) -> + let f (field_name, _, type_expr) = + let comment_opt = + try List.assoc field_name name_comment_list + with Not_found -> None + in { + of_name = field_name ; + of_type = Odoc_env.subst_type env type_expr ; + of_text = comment_opt ; + } + in + Object_type (List.map f @@ fst @@ Ctype.flatten_fields fields) + | _ -> Other (Odoc_env.subst_type env type_expr) + + let get_field env name_comment_list {Types.ld_id=field_name;ld_mutable=mutable_flag;ld_type=type_expr} = + let field_name = Ident.name field_name in + let comment_opt = + try List.assoc field_name name_comment_list + with Not_found -> None + in + { + rf_name = field_name ; + rf_mutable = mutable_flag = Mutable ; + rf_type = Odoc_env.subst_type env type_expr ; + rf_text = comment_opt + } let get_type_kind env name_comment_list type_kind = match type_kind with Types.Type_abstract -> Odoc_type.Type_abstract | Types.Type_variant l -> - let f {Types.cd_id=constructor_name;cd_args=type_expr_list;cd_res=ret_type} = + let f {Types.cd_id=constructor_name;cd_args;cd_res=ret_type} = let constructor_name = Ident.name constructor_name in let comment_opt = - try List.assoc constructor_name name_comment_list + try List.assoc constructor_name name_comment_list with Not_found -> None in + let vc_args = + match cd_args with + | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type env) l) + | Cstr_record l -> Cstr_record (List.map (get_field env []) l) + in { vc_name = constructor_name ; - vc_args = List.map (Odoc_env.subst_type env) type_expr_list ; + vc_args; vc_ret = may_map (Odoc_env.subst_type env) ret_type; vc_text = comment_opt } @@ -235,20 +306,11 @@ module Analyser = Odoc_type.Type_variant (List.map f l) | Types.Type_record (l, _) -> - let f {Types.ld_id=field_name;ld_mutable=mutable_flag;ld_type=type_expr} = - let field_name = Ident.name field_name in - let comment_opt = - try List.assoc field_name name_comment_list - with Not_found -> None - in - { - rf_name = field_name ; - rf_mutable = mutable_flag = Mutable ; - rf_type = Odoc_env.subst_type env type_expr ; - rf_text = comment_opt - } - in - Odoc_type.Type_record (List.map f l) + Odoc_type.Type_record (List.map (get_field env name_comment_list) l) + + | Types.Type_open -> + Odoc_type.Type_open + let erased_names_of_constraints constraints acc = List.fold_right (fun constraint_ acc -> @@ -267,6 +329,7 @@ module Analyser = | Parsetree.Psig_attribute _ | Parsetree.Psig_extension _ | Parsetree.Psig_value _ + | Parsetree.Psig_typext _ | Parsetree.Psig_exception _ | Parsetree.Psig_open _ | Parsetree.Psig_include _ @@ -297,7 +360,8 @@ module Analyser = match ele2.Parsetree.pctf_desc with Parsetree.Pctf_val (_, _, _, _) | Parsetree.Pctf_method (_, _, _, _) - | Parsetree.Pctf_constraint (_, _) -> loc.Location.loc_start.Lexing.pos_cnum + | Parsetree.Pctf_constraint (_, _) + | Parsetree.Pctf_attribute _ -> loc.Location.loc_start.Lexing.pos_cnum | Parsetree.Pctf_inherit class_type -> class_type.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum | Parsetree.Pctf_extension _ -> assert false @@ -456,6 +520,11 @@ module Analyser = in let (inher_l, eles) = f (pos_end + maybe_more) q in (inh :: inher_l , eles_comments @ eles) + | Parsetree.Pctf_attribute _ -> + let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in + (inher_l, eles_comments @ eles) + | Parsetree.Pctf_extension _ -> assert false in f last_pos class_type_field_list @@ -550,18 +619,105 @@ module Analyser = let new_env = Odoc_env.add_value env v.val_name in (maybe_more, new_env, [ Element_value v ]) - | Parsetree.Psig_exception exception_decl -> - let name = exception_decl.Parsetree.pcd_name in - let types_excep_decl = - try Signature_search.search_exception table name.txt + | Parsetree.Psig_typext tyext -> + let new_env, types_ext_list, last_ext = + List.fold_left + (fun (env_acc, exts_acc, _) -> fun {Parsetree.pext_name = { txt = name }} -> + let complete_name = Name.concat current_module_name name in + let env_acc = Odoc_env.add_extension env_acc complete_name in + let types_ext = + try Signature_search.search_extension table name + with Not_found -> + raise (Failure (Odoc_messages.extension_not_found current_module_name name)) + in + env_acc, ((name, types_ext) :: exts_acc), Some types_ext + ) + (env, [], None) + tyext.Parsetree.ptyext_constructors + in + let ty_path, ty_params, priv = + match last_ext with + None -> assert false + | Some ext -> ext.ext_type_path, ext.ext_type_params, ext.ext_private + in + let new_te = + { + te_info = comment_opt; + te_type_name = + Odoc_env.full_type_name new_env (Name.from_path ty_path); + te_type_parameters = + List.map (Odoc_env.subst_type new_env) ty_params; + te_private = priv; + te_constructors = []; + te_loc = { loc_impl = None ; loc_inter = Some sig_item_loc} ; + te_code = + ( + if !Odoc_global.keep_code then + Some (get_string_of_file pos_start_ele pos_end_ele) + else + None + ) ; + } + in + let rec analyse_extension_constructors maybe_more exts_acc types_ext_list = + match types_ext_list with + [] -> (maybe_more, List.rev exts_acc) + | (name, types_ext) :: q -> + let ext_loc_end = types_ext.Types.ext_loc.Location.loc_end.Lexing.pos_cnum in + let xt_args = + match types_ext.ext_args with + | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type new_env) l) + | Cstr_record l -> Cstr_record (List.map (get_field new_env []) l) + in + let new_x = + { + xt_name = Name.concat current_module_name name ; + xt_args; + xt_ret = may_map (Odoc_env.subst_type new_env) types_ext.ext_ret_type ; + xt_type_extension = new_te; + xt_alias = None ; + xt_loc = { loc_impl = None ; loc_inter = Some types_ext.Types.ext_loc} ; + xt_text = None; + } + in + let pos_limit2 = + match q with + [] -> pos_limit + | (_, next) :: _ -> next.Types.ext_loc.Location.loc_start.Lexing.pos_cnum + in + let s = get_string_of_file ext_loc_end pos_limit2 in + let (maybe_more, comment_opt) = My_ir.just_after_special !file_name s in + new_x.xt_text <- comment_opt; + analyse_extension_constructors maybe_more (new_x :: exts_acc) q + in + let (maybe_more, exts) = analyse_extension_constructors 0 [] types_ext_list in + new_te.te_constructors <- exts; + let (maybe_more2, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file (pos_end_ele + maybe_more) pos_limit) + in + new_te.te_info <- merge_infos new_te.te_info info_after_opt ; + (maybe_more + maybe_more2, new_env, [ Element_type_extension new_te ]) + + | Parsetree.Psig_exception ext -> + let name = ext.Parsetree.pext_name in + let types_ext = + try Signature_search.search_extension table name.txt with Not_found -> raise (Failure (Odoc_messages.exception_not_found current_module_name name.txt)) in + let ex_args = + match types_ext.ext_args with + | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type env) l) + | Cstr_record l -> Cstr_record (List.map (get_field env []) l) + in let e = { ex_name = Name.concat current_module_name name.txt ; ex_info = comment_opt ; - ex_args = List.map (Odoc_env.subst_type env) types_excep_decl.exn_args ; + ex_args; + ex_ret = may_map (Odoc_env.subst_type env) types_ext.ext_ret_type ; ex_alias = None ; ex_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; ex_code = @@ -579,7 +735,7 @@ module Analyser = (get_string_of_file pos_end_ele pos_limit) in e.ex_info <- merge_infos e.ex_info info_after_opt ; - let new_env = Odoc_env.add_exception env e.ex_name in + let new_env = Odoc_env.add_extension env e.ex_name in (maybe_more, new_env, [ Element_exception e ]) | Parsetree.Psig_type name_type_decl_list -> @@ -613,10 +769,10 @@ module Analyser = | td :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in let (maybe_more, name_comment_list) = - name_comment_from_type_kind + name_comment_from_type_decl type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum pos_limit2 - type_decl.Parsetree.ptype_kind + type_decl in print_DEBUG ("Type "^name.txt^" : "^(match assoc_com with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)); let f_DEBUG (name, c_opt) = print_DEBUG ("constructor/field "^name^": "^(match c_opt with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)) in @@ -645,9 +801,11 @@ module Analyser = ty_kind = type_kind; ty_private = sig_type_decl.Types.type_private; ty_manifest = - (match sig_type_decl.Types.type_manifest with - None -> None - | Some t -> Some (Odoc_env.subst_type new_env t)); + begin match sig_type_decl.Types.type_manifest with + | None -> None + | Some t -> + Some (manifest_structure env name_comment_list t) + end ; ty_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; ty_code = ( @@ -866,7 +1024,7 @@ module Analyser = in (maybe_more, new_env2, [ Element_module_type mt ]) - | Parsetree.Psig_include (module_type, _attrs) -> + | Parsetree.Psig_include incl -> let rec f = function Parsetree.Pmty_ident longident -> Name.from_longident longident.txt @@ -885,7 +1043,7 @@ module Analyser = end | Parsetree.Pmty_extension _ -> assert false in - let name = f module_type.Parsetree.pmty_desc in + let name = f incl.Parsetree.pincl_mod.Parsetree.pmty_desc in let full_name = Odoc_env.full_module_or_module_type_name env name in let im = { @@ -1148,11 +1306,19 @@ module Analyser = and analyse_module_kind ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with - Parsetree.Pmty_ident longident - | Parsetree.Pmty_alias longident -> + | Parsetree.Pmty_ident longident -> let k = analyse_module_type_kind env current_module_name module_type sig_module_type in Module_with ( k, "" ) - + | Parsetree.Pmty_alias longident -> + begin + match sig_module_type with + Types.Mty_alias path -> + let alias_name = Odoc_env.full_module_name env (Name.from_path path) in + let ma = { ma_name = alias_name ; ma_module = None } in + Module_alias ma + | _ -> + raise (Failure "Parsetree.Pmty_alias _ but not Types.Mty_alias _") + end | Parsetree.Pmty_signature signature -> ( let signature = filter_out_erased_items_from_signature erased signature in |