%-----------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et %-----------------------------------------------------------------------------% % Copyright (C) 2006-2012 The University of Melbourne. % Copyright (C) 2014-2025 The Mercury team. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% % % Module: xml_documentation.m. % Main authors: petdr. % % This module outputs an XML representation of a module, % which can then be transformed by a stylesheet into some other % documentation format. % %-----------------------------------------------------------------------------% :- module check_hlds.xml_documentation. :- interface. :- import_module hlds. :- import_module hlds.hlds_module. :- import_module io. % Output a representation of the module in XML which can be used % to document the module. % :- pred xml_documentation(io.text_output_stream::in, module_info::in, io::di, io::uo) is det. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. :- import_module hlds.hlds_class. :- import_module hlds.hlds_data. :- import_module hlds.hlds_markers. :- import_module hlds.hlds_pred. :- import_module hlds.hlds_proc_util. :- import_module hlds.pred_name. :- import_module hlds.pred_table. :- import_module hlds.status. :- import_module libs. :- import_module libs.file_util. :- import_module mdbcomp. :- import_module mdbcomp.builtin_modules. :- import_module mdbcomp.prim_data. :- import_module mdbcomp.sym_name. :- import_module parse_tree. :- import_module parse_tree.file_names. :- import_module parse_tree.prog_data. :- import_module parse_tree.prog_item. :- import_module parse_tree.prog_parse_tree. :- import_module parse_tree.source_file_map. :- import_module bool. :- import_module char. :- import_module int. :- import_module list. :- import_module map. :- import_module maybe. :- import_module one_or_more. :- import_module set. :- import_module string. :- import_module term_context. :- import_module term_to_xml. :- import_module varset. %-----------------------------------------------------------------------------% % Record all the locations of comments in a file. % :- type line_type_map ---> line_type_map( % For each line number, record what is on that line. line_types :: map(int, typed_line) ). :- type typed_line ---> blank % A line containing only whitespace. ; comment(string) % A line containing just a comment. ; code_and_comment(string) % A line which contains both a comment and code. ; code. % A line containing code. %-----------------------------------------------------------------------------% xml_documentation(ProgressStream, ModuleInfo, !IO) :- module_info_get_name(ModuleInfo, ModuleName), module_name_to_cur_dir_file_name(ext_cur_user_xml, ModuleName, XmlFileName), lookup_module_source_file(ModuleName, SrcFileName, !IO), io.open_input(SrcFileName, SrcResult, !IO), ( SrcResult = ok(SrcStream), build_line_type_map(SrcStream, map.init, RawLineTypeMap, !IO), LineTypeMap = line_type_map(RawLineTypeMap), % XXX We should find the ":- module " declaration % and get the comment from there. ModuleComment = get_comment_forwards(LineTypeMap, 1), io.open_output(XmlFileName, XmlOpenResult, !IO), ( XmlOpenResult = ok(XmlStream), MIXmlDoc = module_info_xml_doc(LineTypeMap, ModuleComment, ModuleInfo), write_xml_doc(XmlStream, MIXmlDoc, !IO) ; XmlOpenResult = error(XmlIOError), module_info_get_globals(ModuleInfo, Globals), report_cannot_open_file_for_output(ProgressStream, Globals, XmlFileName, XmlIOError, !IO) ) ; SrcResult = error(SrcIOError), module_info_get_globals(ModuleInfo, Globals), report_cannot_open_file_for_input(ProgressStream, Globals, SrcFileName, SrcIOError, !IO) ). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% % Build the line_type_map data structure representing the code read from % the given this stream. % :- pred build_line_type_map(io.text_input_stream::in, map(int, typed_line)::in, map(int, typed_line)::out, io::di, io::uo) is det. build_line_type_map(S, !RawLineTypeMap, !IO) :- io.get_line_number(S, LineNumber, !IO), io.read_line(S, LineResult, !IO), ( LineResult = ok(Line), map.set(LineNumber, type_the_line(Line), !RawLineTypeMap), build_line_type_map(S, !RawLineTypeMap, !IO) ; LineResult = eof ; LineResult = error(E), % XXX we should recover more gracefully from this error. unexpected($pred, io.error_message(E)) ). % Given a list of characters representing one line, % return the typed (classified) version of the line. % % Note this predicate is pretty stupid at the moment. % It only recognizes lines which contains % comments. % It also is confused by % characters in strings, etc. etc. % :- func type_the_line(list(character)) = typed_line. type_the_line(Line) = LineType :- list.drop_while(char.is_whitespace, Line, Rest), list.take_while(is_not_comment_char, Rest, Decl, Comment), ( Rest = [], LineType = blank ; Rest = [_ | _], ( Comment = [], LineType = code ; Comment = [_ | _], ( Decl = [], LineType = comment(string.from_char_list(Comment)) ; Decl = [_ | _], LineType = code_and_comment(string.from_char_list(Comment)) ) ) ). :- pred is_not_comment_char(char::in) is semidet. is_not_comment_char(C) :- C \= '%'. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% % Comment selection strategies % If the prog_context given has a comment associated with it % add a child element which contains the comment to the given XML. % :- func maybe_add_comment(line_type_map, prog_context, xml) = xml. maybe_add_comment(LineTypeMap, Context, Xml) = ( if Xml = elem(N, As, Cs) then ( if Comment = get_comment(LineTypeMap, Context), Comment \= "" then elem(N, As, [elem("comment", [], [data(Comment)]) | Cs]) else Xml ) else unexpected($pred, "not an element") ). % Get the comment string associated with the given prog_context. % :- func get_comment(line_type_map, prog_context) = string. get_comment(LineTypeMap, context(_, Line)) = % XXX At a later date this hard-coded strategy should be made % more flexible. What I imagine is that the user would pass a string % saying in what order they wish to search for comments. ( if comment_on_current_line(LineTypeMap, Line, C) then C else if comment_directly_above(LineTypeMap, Line, C) then C else "" ). %-----------------------------------------------------------------------------% % Succeeds if the current line has a comment. % The comment is extended with all the lines following % the current line which just contain a comment. % :- pred comment_on_current_line(line_type_map::in, int::in, string::out) is semidet. comment_on_current_line(LineTypeMap, Line, Comment) :- map.search(LineTypeMap ^ line_types, Line, code_and_comment(Comment0)), RestComment = get_comment_forwards(LineTypeMap, Line + 1), Comment = Comment0 ++ RestComment. % Succeeds if the comment is directly above the current line. % The comment above ends when we find a line above the current line % which doesn't just contain a comment. % :- pred comment_directly_above(line_type_map::in, int::in, string::out) is semidet. comment_directly_above(LineTypeMap, Line, Comment) :- map.search(LineTypeMap ^ line_types, Line - 1, comment(_)), Comment = get_comment_backwards(LineTypeMap, Line - 1). % Return the string which represents the comment starting at the given % line. The comment ends when a line which is not a plain comment line % is found. % :- func get_comment_forwards(line_type_map, int) = string. get_comment_forwards(LineTypeMap, Line) = Comment :- ( if map.search(LineTypeMap ^ line_types, Line, LineType) then ( LineType = comment(CurrentComment), CommentBelow = get_comment_forwards(LineTypeMap, Line + 1), Comment = CurrentComment ++ CommentBelow ; ( LineType = blank ; LineType = code ; LineType = code_and_comment(_) ), Comment = "" ) else Comment = "" ). % Return the string which represents the comment ending at the given line. % The comment extends backwards until the line above the given line is not % a comment only line. % :- func get_comment_backwards(line_type_map, int) = string. get_comment_backwards(LineTypeMap, Line) = Comment :- ( if map.search(LineTypeMap ^ line_types, Line, LineType) then ( LineType = comment(CurrentComment), CommentAbove = get_comment_backwards(LineTypeMap, Line - 1), Comment = CommentAbove ++ CurrentComment ; ( LineType = blank ; LineType = code ; LineType = code_and_comment(_) ), Comment = "" ) else Comment = "" ). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- type module_info_xml_doc ---> module_info_xml_doc(line_type_map, string, module_info). :- instance xmlable(module_info_xml_doc) where [ (to_xml(module_info_xml_doc(LineTypeMap, ModuleComment, ModuleInfo)) = Xml :- CommentXml = elem("comment", [], [data(ModuleComment)]), module_info_get_avail_module_map(ModuleInfo, AvailModuleMap), BuiltinModuleNames = set.list_to_set(all_builtin_modules), map.foldl(maybe_add_import_documentation(BuiltinModuleNames), AvailModuleMap, [], ImportsXml), ImportXml = elem("imports", [], ImportsXml), module_info_get_type_table(ModuleInfo, TypeTable), foldl_over_type_ctor_defns(type_documentation(LineTypeMap), TypeTable, [], TypeXmls), TypeXml = elem("types", [], TypeXmls), module_info_get_pred_id_table(ModuleInfo, PredIdTable), map.foldl(pred_documentation(LineTypeMap), PredIdTable, [], PredXmls), PredXml = elem("preds", [], PredXmls), module_info_get_class_table(ModuleInfo, ClassTable), map.foldl(class_documentation(LineTypeMap, PredIdTable), ClassTable, [], ClassXmls), ClassXml = elem("typeclasses", [], ClassXmls), Children = [CommentXml, ImportXml, TypeXml, PredXml, ClassXml], Xml = elem("module", [], Children) ) ]. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% % Output the documentation for one import_module or use_module declaration. % :- pred maybe_add_import_documentation(set(module_name)::in, module_name::in, avail_module_entry::in, list(xml)::in, list(xml)::out) is det. maybe_add_import_documentation(BuiltinModuleNames, ModuleName, AvailEntry, !Xmls) :- ( if set.member(ModuleName, BuiltinModuleNames) then true else XmlName = name_to_xml(ModuleName), AvailEntry = avail_module_entry(Section, ImportOrUse, _Avails), ( Section = ms_interface, XmlVisibility = tagged_string("visibility", "interface") ; Section = ms_implementation, XmlVisibility = tagged_string("visibility", "implementation") ), ( ImportOrUse = import_decl, ImportOrUseWord = "import" ; ImportOrUse = use_decl, ImportOrUseWord = "use" ), Xml = elem(ImportOrUseWord, [], [XmlName, XmlVisibility]), !:Xmls = [Xml | !.Xmls] ). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% % Output the documentation of one type. % :- pred type_documentation(line_type_map::in, type_ctor::in, hlds_type_defn::in, list(xml)::in, list(xml)::out) is det. type_documentation(C, type_ctor(TypeName, TypeArity), TypeDefn, !Xmls) :- get_type_defn_status(TypeDefn, TypeStatus), DefinedInThisModule = type_status_defined_in_this_module(TypeStatus), ( DefinedInThisModule = yes, get_type_defn_body(TypeDefn, TypeBody), get_type_defn_tvarset(TypeDefn, TVarset), get_type_defn_context(TypeDefn, Context), get_type_defn_tparams(TypeDefn, TParams), XmlName = name_to_xml(TypeName), XmlTypeParams = xml_list("type_params", type_param_to_xml(TVarset), TParams), XmlVisibility = type_visibility_to_xml(TypeStatus), Tag = type_xml_tag(TypeBody), Id = attr("id", sym_name_arity_to_id("type", TypeName, TypeArity)), Children = [XmlName, XmlTypeParams, XmlVisibility, prog_context_to_xml(Context) | type_body_to_xml(C, TVarset, TypeBody)], Xml0 = elem(Tag, [Id], Children), Xml = maybe_add_comment(C, Context, Xml0), !:Xmls = [Xml | !.Xmls] ; DefinedInThisModule = no ). :- func type_xml_tag(hlds_type_body) = string. type_xml_tag(hlds_du_type(_)) = "du_type". type_xml_tag(hlds_eqv_type(_)) = "eqv_type". type_xml_tag(hlds_foreign_type(_)) = "foreign_type". type_xml_tag(hlds_solver_type(_)) = "solver_type". type_xml_tag(hlds_abstract_type(_)) = "abstract_type". :- func type_param_to_xml(tvarset, type_param) = xml. type_param_to_xml(TVarset, TVar) = Xml :- TVarName = varset.lookup_name(TVarset, TVar), Xml = tagged_string("type_variable", TVarName). :- func type_body_to_xml(line_type_map, tvarset, hlds_type_body) = list(xml). type_body_to_xml(C, TVarSet, TypeDefnBody) = Xmls :- ( TypeDefnBody = hlds_du_type(TypeBodyDu), TypeBodyDu = type_body_du(OoMCtors, _, _, _, _, _), Ctors = one_or_more_to_list(OoMCtors), Xmls = [xml_list("constructors", constructor_to_xml(C, TVarSet), Ctors)] ; TypeDefnBody = hlds_eqv_type(EqvType), Xmls = [elem("equivalent_type", [], [mer_type_to_xml(TVarSet, EqvType)])] ; TypeDefnBody = hlds_foreign_type(_), % XXX TODO Xmls = [nyi("hlds_foreign_type")] ; TypeDefnBody = hlds_solver_type(_), % XXX TODO Xmls = [nyi("hlds_solver_type")] ; TypeDefnBody = hlds_abstract_type(_), % XXX TODO Xmls = [nyi("hlds_abstract_type")] ). :- func constructor_to_xml(line_type_map, tvarset, constructor) = xml. constructor_to_xml(C, TVarset, Ctor) = Xml :- Ctor = ctor(_Ordinal, MaybeExistConstraints, Name, Args, Arity, Context), ( MaybeExistConstraints = no_exist_constraints, ExistQVars = [], Constraints = [] ; MaybeExistConstraints = exist_constraints(ExistConstraints), ExistConstraints = cons_exist_constraints(ExistQVars, Constraints, _, _) ), Id = attr("id", sym_name_arity_to_id("ctor", Name, Arity)), XmlName = name_to_xml(Name), XmlContext = prog_context_to_xml(Context), XmlArgs = xml_list("ctor_args", constructor_arg_to_xml(C, TVarset), Args), XmlExistQVars = xml_list("ctor_exist_vars", type_param_to_xml(TVarset), ExistQVars), XmlConstraints = xml_list("ctor_constraints", prog_constraint_to_xml(TVarset), Constraints), Xml0 = elem("constructor", [Id], [XmlName, XmlContext, XmlArgs, XmlExistQVars, XmlConstraints]), Xml = maybe_add_comment(C, Context, Xml0). :- func constructor_arg_to_xml(line_type_map, tvarset, constructor_arg) = xml. constructor_arg_to_xml(C, TVarset, CtorArg) = Xml :- CtorArg = ctor_arg(MaybeCtorFieldName, Type, Context), XmlType = elem("arg_type", [], [mer_type_to_xml(TVarset, Type)]), XmlContext = prog_context_to_xml(Context), ( MaybeCtorFieldName = yes(ctor_field_name(FieldName, _FieldNameCtxt)), Id = attr("id", sym_name_to_id("field", FieldName)), XmlMaybeFieldName = [elem("field", [Id], [name_to_xml(FieldName)])] ; MaybeCtorFieldName = no, XmlMaybeFieldName = [] ), Xml0 = elem("ctor_arg", [], [XmlType, XmlContext | XmlMaybeFieldName]), Xml = maybe_add_comment(C, Context, Xml0). :- func mer_type_to_xml(tvarset, mer_type) = xml. mer_type_to_xml(TVarset, type_variable(TVar, _)) = type_param_to_xml(TVarset, TVar). mer_type_to_xml(TVarset, defined_type(TypeName, Args, _)) = Xml :- Ref = attr("ref", sym_name_arity_to_id("type", TypeName, length(Args))), XmlName = name_to_xml(TypeName), XmlArgs = xml_list("type_args", mer_type_to_xml(TVarset), Args), Xml = elem("type", [Ref], [XmlName, XmlArgs]). mer_type_to_xml(_, builtin_type(builtin_type_int(IntType))) = Xml :- int_type_module_name(IntType, IntTypeString), Xml = elem(IntTypeString, [], []). mer_type_to_xml(_, builtin_type(builtin_type_float)) = elem("float", [], []). mer_type_to_xml(_, builtin_type(builtin_type_string)) = elem("string", [], []). mer_type_to_xml(_, builtin_type(builtin_type_char)) = elem("character", [], []). mer_type_to_xml(TVarset, higher_order_type(PorF, Types, _, _)) = Xml :- ( PorF = pf_predicate, XmlTypes = xml_list("higher_order_type_args", mer_type_to_xml(TVarset), Types), XmlChildren = [XmlTypes] ; PorF = pf_function, list.det_split_last(Types, ArgTypes, ResultType), XmlTypes = xml_list("higher_order_type_args", mer_type_to_xml(TVarset), ArgTypes), XmlReturn = elem("return_type", [], [mer_type_to_xml(TVarset, ResultType)]), XmlChildren = [XmlTypes, XmlReturn] ), Xml = elem("higher_order_type", [], XmlChildren). mer_type_to_xml(TVarset, tuple_type(Types, _)) = Xml :- XmlArgs = xml_list("tuple_types", mer_type_to_xml(TVarset), Types), Xml = elem("tuple", [], [XmlArgs]). mer_type_to_xml(_, apply_n_type(_, _, _)) = nyi("apply_n_type"). mer_type_to_xml(_, kinded_type(_, _)) = nyi("kinded_type"). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- pred pred_documentation(line_type_map::in, pred_id::in, pred_info::in, list(xml)::in, list(xml)::out) is det. pred_documentation(C, _PredId, PredInfo, !Xml) :- pred_info_get_status(PredInfo, PredStatus), pred_info_get_origin(PredInfo, Origin), pred_info_get_markers(PredInfo, Markers), ( if pred_status_defined_in_this_module(PredStatus) = yes, Origin = origin_user(user_made_pred(_, _, _)), not marker_is_present(Markers, marker_class_method) then Xml = predicate_documentation(C, PredInfo), !:Xml = [Xml | !.Xml] else true ). :- func predicate_documentation(line_type_map, pred_info) = xml. predicate_documentation(C, PredInfo) = Xml :- pred_info_get_typevarset(PredInfo, TVarset), pred_info_get_exist_quant_tvars(PredInfo, Exists), IsPredOrFunc = pred_info_is_pred_or_func(PredInfo), Module = pred_info_module(PredInfo), Name = pred_info_name(PredInfo), PredName = qualified(Module, Name), pred_info_get_status(PredInfo, PredStatus), Types = get_orig_arg_types(PredInfo), pred_info_get_class_context(PredInfo, Constraints), pred_info_get_context(PredInfo, Context), ( IsPredOrFunc = pf_predicate, Tag = "predicate" ; IsPredOrFunc = pf_function, Tag = "function" ), pred_info_get_orig_arity(PredInfo, PredInfoArity), PredInfoArity = pred_form_arity(PredInfoArityInt), % user_arity_pred_form_arity(IsPredOrFunc, UserArity, PredInfoArity), % UserArity = user_arity(UserArityInt), % XXX Should this be UserArityInt instead of PredInfoArityInt? Id = sym_name_arity_to_id(Tag, PredName, PredInfoArityInt), XmlName = name_to_xml(PredName), XmlContext = prog_context_to_xml(Context), XmlTypes = xml_list("pred_types", mer_type_to_xml(TVarset), Types), XmlExistVars = xml_list("pred_exist_vars", type_param_to_xml(TVarset), Exists), XmlConstraints = univ_exist_constraints_to_xml(TVarset, Constraints), XmlVisibility = pred_visibility_to_xml(PredStatus), pred_info_get_proc_table(PredInfo, ProcTable), map.foldl(pred_mode_documentation(C), ProcTable, [], XmlProcs), XmlModes = elem("pred_modes", [], XmlProcs), Xml0 = elem(Tag, [attr("id", Id)], [XmlName, XmlTypes, XmlContext, XmlExistVars, XmlConstraints, XmlVisibility, XmlModes]), Xml = maybe_add_comment(C, Context, Xml0). :- func get_orig_arg_types(pred_info) = list(mer_type). get_orig_arg_types(PredInfo) = Types :- pred_info_get_arg_types(PredInfo, Types0), pred_info_get_orig_arity(PredInfo, pred_form_arity(PredFormArity)), Types = keep_last_n(PredFormArity, Types0). :- import_module require. :- func keep_last_n(int, list(T)) = list(T). keep_last_n(N, L0) = ( if list.drop(list.length(L0) - N, L0, L) then L else func_error("keep_last_n") ). :- func univ_exist_constraints_to_xml(tvarset, univ_exist_constraints) = xml. univ_exist_constraints_to_xml(TVarset, Constraints) = Xml :- Constraints = univ_exist_constraints(Univs, Exists), XmlUnivs = xml_list("pred_universal", prog_constraint_to_xml(TVarset), Univs), XmlExists = xml_list("pred_exist", prog_constraint_to_xml(TVarset), Exists), Xml = elem("pred_constraints", [], [XmlUnivs, XmlExists]). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- pred pred_mode_documentation(line_type_map::in, proc_id::in, proc_info::in, list(xml)::in, list(xml)::out) is det. pred_mode_documentation(_C, _ProcId, ProcInfo, !Xml) :- % XXX do we ever need to remove arguments here? proc_info_get_inst_varset(ProcInfo, IVarSet), proc_info_declared_argmodes(ProcInfo, Modes), proc_info_interface_determinism(ProcInfo, Determinism), XmlModes = xml_list("modes", mer_mode_to_xml(IVarSet), Modes), XmlDet = determinism_to_xml(Determinism), Xml = elem("pred_mode", [], [XmlModes, XmlDet]), !:Xml = [Xml | !.Xml]. :- func mer_mode_to_xml(inst_varset, mer_mode) = xml. mer_mode_to_xml(InstVarSet, Mode) = Xml :- ( Mode = from_to_mode(A, B), XmlFrom = xml_list("from", mer_inst_to_xml(InstVarSet), [A]), XmlTo = xml_list("to", mer_inst_to_xml(InstVarSet), [B]), Xml = elem("inst_to_inst", [], [XmlFrom, XmlTo]) ; Mode = user_defined_mode(Name, Args), Ref = attr("ref", sym_name_arity_to_id("mode", Name, length(Args))), XmlArgs = xml_list("mode_args", mer_inst_to_xml(InstVarSet), Args), Xml = elem("user_defined_mode", [Ref], [name_to_xml(Name), XmlArgs]) ). :- func mer_inst_to_xml(inst_varset, mer_inst) = xml. mer_inst_to_xml(InstVarSet, Inst) = Xml :- ( Inst = free, Xml = elem("free", [], []) ; Inst = bound(U, _, BoundFunctors), XmlUniq = uniqueness_to_xml(U), XmlInsts = xml_list("bound_functors", bound_functor_to_xml(InstVarSet), BoundFunctors), Xml = elem("bound", [], [XmlUniq, XmlInsts]) ; Inst = ground(U, _), Xml = elem("ground", [], [uniqueness_to_xml(U)]) ; Inst = any(U, _), Xml = elem("any", [], [uniqueness_to_xml(U)]) ; Inst = not_reached, Xml = elem("not_reached", [], []) ; Inst = inst_var(InstVar), InstVarName = varset.lookup_name(InstVarSet, InstVar), Xml = tagged_string("inst_var", InstVarName) ; Inst = constrained_inst_vars(_, SubInst), % XXX We do we ignore the constraint? Xml = mer_inst_to_xml(InstVarSet, SubInst) ; Inst = defined_inst(Name), XmlName = inst_name_to_xml(InstVarSet, Name), Xml = elem("defined_inst", [], [XmlName]) ). :- func inst_name_to_xml(inst_varset, inst_name) = xml. inst_name_to_xml(InstVarSet, user_inst(Name, Insts)) = Xml :- Ref = attr("ref", sym_name_arity_to_id("inst", Name, length(Insts))), XmlName = name_to_xml(Name), XmlInsts = xml_list("inst_args", mer_inst_to_xml(InstVarSet), Insts), Xml = elem("user_inst", [Ref], [XmlName, XmlInsts]). inst_name_to_xml(_, unify_inst(_, _, _, _)) = nyi("unify_inst"). inst_name_to_xml(_, merge_inst(_, _)) = nyi("merge_inst"). inst_name_to_xml(_, ground_inst(_, _, _, _)) = nyi("ground_inst"). inst_name_to_xml(_, any_inst(_, _, _, _)) = nyi("any_inst"). inst_name_to_xml(_, shared_inst(_)) = nyi("shared_inst"). inst_name_to_xml(_, mostly_uniq_inst(_)) = nyi("mostly_uniq_inst"). inst_name_to_xml(_, typed_ground(_, _)) = nyi("typed_ground"). inst_name_to_xml(_, typed_inst(_, _)) = nyi("typed_inst"). :- func uniqueness_to_xml(uniqueness) = xml. uniqueness_to_xml(U) = tagged_string("uniqueness", string(U)). :- func bound_functor_to_xml(inst_varset, bound_functor) = xml. bound_functor_to_xml(InstVarSet, bound_functor(ConsId, Insts)) = Xml :- XmlCons = cons_id_to_xml(ConsId), XmlInsts = xml_list("insts", mer_inst_to_xml(InstVarSet), Insts), Xml = elem("bound_functor", [], [XmlCons, XmlInsts]). :- func cons_id_to_xml(cons_id) = xml. cons_id_to_xml(du_data_ctor(du_ctor(Name, Arity, _))) = elem("cons", [], [name_to_xml(Name), arity_to_xml(Arity)]). % XXX We could do better for tuple_cons and closure_cons. % The return values here are just a continuation of what we used to do. cons_id_to_xml(tuple_cons(Arity)) = elem("cons", [], [name_to_xml(unqualified("{}")), arity_to_xml(Arity)]). cons_id_to_xml(some_int_const(IntConst)) = ( if IntConst = int_const(I) then tagged_int("int", I) else unexpected($pred, "NYI non-int integer const") ). cons_id_to_xml(float_const(F)) = tagged_float("float", F). cons_id_to_xml(char_const(C)) = tagged_char("char", C). cons_id_to_xml(string_const(S)) = tagged_string("string", S). cons_id_to_xml(impl_defined_const(_)) = nyi("impl_defined_const"). cons_id_to_xml(closure_cons(_)) = nyi("closure_cons"). cons_id_to_xml(type_ctor_info_const(_, _, _)) = nyi("type_ctor_info_const"). cons_id_to_xml(base_typeclass_info_const(_,_,_,_)) = nyi("base_typeclass_info_const"). cons_id_to_xml(type_info_cell_constructor(_)) = nyi("type_info_cell_constructor"). cons_id_to_xml(typeclass_info_cell_constructor) = nyi("typeclass_info_cell_constructor"). cons_id_to_xml(type_info_const(_)) = nyi("type_info_const"). cons_id_to_xml(typeclass_info_const(_)) = nyi("typeclass_info_const"). cons_id_to_xml(ground_term_const(_, _)) = nyi("ground_term_const"). cons_id_to_xml(tabling_info_const(_)) = nyi("tabling_info_const"). cons_id_to_xml(table_io_entry_desc(_)) = nyi("table_io_entry_desc"). cons_id_to_xml(deep_profiling_proc_layout(_)) = nyi("deep_profiling_proc_layout"). :- func arity_to_xml(int) = xml. arity_to_xml(Arity) = tagged_int("arity", Arity). :- func determinism_to_xml(determinism) = xml. determinism_to_xml(detism_det) = tagged_string("determinism", "det"). determinism_to_xml(detism_semi) = tagged_string("determinism", "semidet"). determinism_to_xml(detism_multi) = tagged_string("determinism", "multi"). determinism_to_xml(detism_non) = tagged_string("determinism", "nondet"). determinism_to_xml(detism_cc_non) = tagged_string("determinism", "cc_nondet"). determinism_to_xml(detism_cc_multi) = tagged_string("determinism", "cc_multi"). determinism_to_xml(detism_erroneous) = tagged_string("determinism", "erroneous"). determinism_to_xml(detism_failure) = tagged_string("determinism", "failure"). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- pred class_documentation(line_type_map::in, pred_id_table::in, class_id::in, hlds_class_defn::in, list(xml)::in, list(xml)::out) is det. class_documentation(C, PredTable, class_id(Name, Arity), ClassDefn, !Xml) :- TypeClassStatus = ClassDefn ^ classdefn_status, DefinedInThisModule = typeclass_status_defined_in_this_module(TypeClassStatus), ( DefinedInThisModule = yes, Id = sym_name_arity_to_id("class", Name, Arity), Context = ClassDefn ^ classdefn_context, TVarset = ClassDefn ^ classdefn_tvarset, Vars = ClassDefn ^ classdefn_vars, XmlName = name_to_xml(Name), XmlClassVars = xml_list("class_vars", type_param_to_xml(TVarset), Vars), XmlSupers = xml_list("superclasses", prog_constraint_to_xml(TVarset), ClassDefn ^ classdefn_supers), XmlFundeps = xml_list("fundeps", fundep_to_xml(TVarset, Vars), ClassDefn ^ classdefn_fundeps), XmlMethods = class_methods_to_xml(C, PredTable, ClassDefn ^ classdefn_method_infos), XmlVisibility = typeclass_visibility_to_xml(TypeClassStatus), XmlContext = prog_context_to_xml(Context), Xml0 = elem("typeclass", [attr("id", Id)], [XmlName, XmlClassVars, XmlSupers, XmlFundeps, XmlMethods, XmlVisibility, XmlContext]), Xml = maybe_add_comment(C, Context, Xml0), !:Xml = [Xml | !.Xml] ; DefinedInThisModule = no ). :- func fundep_to_xml(tvarset, list(tvar), hlds_class_fundep) = xml. fundep_to_xml(TVarset, Vars, fundep(Domain, Range)) = Xml :- XmlDomain = fundep_to_xml_2("domain", TVarset, Vars, Domain), XmlRange = fundep_to_xml_2("range", TVarset, Vars, Range), Xml = elem("fundep", [], [XmlDomain, XmlRange]). :- func fundep_to_xml_2(string, tvarset, list(tvar), set(hlds_class_argpos)) = xml. fundep_to_xml_2(Tag, TVarset, Vars, Set) = xml_list(Tag, type_param_to_xml(TVarset), restrict_list_elements(Set, Vars)). :- func class_methods_to_xml(line_type_map, pred_id_table, list(method_info)) = xml. class_methods_to_xml(C, PredTable, MethodInfos) = Xml :- MethodInfoPredId = ( func(method_info(_, _, PredProcId, _)) = PredId :- PredProcId = proc(PredId, _) ), AllPredIds = list.map(MethodInfoPredId, MethodInfos), PredIds = list.sort_and_remove_dups(AllPredIds), PredInfos = list.map(func(PredId) = map.lookup(PredTable, PredId), PredIds), Xml = xml_list("methods", predicate_documentation(C), PredInfos). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- func name_to_xml(sym_name) = xml. name_to_xml(unqualified(Name)) = tagged_string("unqualified", Name). name_to_xml(qualified(Module, Name)) = elem("qualified", [], [ tagged_string("module", sym_name_to_string(Module)), tagged_string("name", Name)]). %-----------------------------------------------------------------------------% :- func prog_context_to_xml(prog_context) = xml. prog_context_to_xml(context(FileName, LineNumber)) = elem("context", [], [ tagged_string("filename", FileName), tagged_int("line", LineNumber)]). %-----------------------------------------------------------------------------% :- func prog_constraint_to_xml(tvarset, prog_constraint) = xml. prog_constraint_to_xml(TVarset, Constraint) = Xml :- Constraint = constraint(ClassName, ArgTypes), Id = sym_name_arity_to_id("constraint", ClassName, list.length(ArgTypes)), XmlName = name_to_xml(ClassName), XmlTypes = xml_list("constraint_types", mer_type_to_xml(TVarset), ArgTypes), Xml = elem("constraint", [attr("ref", Id)], [XmlName, XmlTypes]). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- func type_visibility_to_xml(type_status) = xml. type_visibility_to_xml(Status) = tagged_string("visibility", Visibility) :- ( if type_status_defined_in_impl_section(Status) = yes then ( if Status = type_status(status_abstract_exported) then Visibility = "abstract" else Visibility = "implementation" ) else Visibility = "interface" ). :- func inst_visibility_to_xml(inst_status) = xml. :- pragma consider_used(func(inst_visibility_to_xml/1)). inst_visibility_to_xml(Status) = tagged_string("visibility", Visibility) :- ( if inst_status_defined_in_impl_section(Status) = yes then Visibility = "implementation" else Visibility = "interface" ). :- func mode_visibility_to_xml(mode_status) = xml. :- pragma consider_used(func(mode_visibility_to_xml/1)). mode_visibility_to_xml(Status) = tagged_string("visibility", Visibility) :- ( if mode_status_defined_in_impl_section(Status) = yes then Visibility = "implementation" else Visibility = "interface" ). :- func typeclass_visibility_to_xml(typeclass_status) = xml. typeclass_visibility_to_xml(Status) = tagged_string("visibility", Visibility) :- ( if typeclass_status_defined_in_impl_section(Status) = yes then ( if Status = typeclass_status(status_abstract_exported) then Visibility = "abstract" else Visibility = "implementation" ) else Visibility = "interface" ). :- func instance_visibility_to_xml(instance_status) = xml. :- pragma consider_used(func(instance_visibility_to_xml/1)). instance_visibility_to_xml(Status) = tagged_string("visibility", Visibility) :- ( if instance_status_defined_in_impl_section(Status) = yes then ( if Status = instance_status(status_abstract_exported) then Visibility = "abstract" else Visibility = "implementation" ) else Visibility = "interface" ). :- func pred_visibility_to_xml(pred_status) = xml. pred_visibility_to_xml(Status) = tagged_string("visibility", Visibility) :- ( if pred_status_defined_in_impl_section(Status) = yes then ( if Status = pred_status(status_abstract_exported) then Visibility = "abstract" else Visibility = "implementation" ) else Visibility = "interface" ). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% % sym_name_to_id(P, S) converts the sym_name, S, into % a string with prefix, P, prefixed to the generated name. % :- func sym_name_to_id(string, sym_name) = string. sym_name_to_id(Prefix, Name) = prefixed_sym_name(Prefix, Name). % sym_name_to_id(P, S, A) converts the sym_name, S, with % arity, A, into a string with prefix, P, prefixed to the % generated name. % :- func sym_name_arity_to_id(string, sym_name, int) = string. sym_name_arity_to_id(Prefix, Name, Arity) = prefixed_sym_name(Prefix, Name) ++ "-" ++ int_to_string(Arity). :- func prefixed_sym_name(string, sym_name) = string. prefixed_sym_name(Prefix, Name) = Prefix ++ "." ++ sym_name_to_string(Name). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- func tagged_int(string, int) = xml. tagged_int(E, I) = elem(E, [], [data(int_to_string(I))]). :- func tagged_float(string, float) = xml. tagged_float(E, F) = elem(E, [], [data(float_to_string(F))]). :- func tagged_char(string, char) = xml. tagged_char(E, C) = elem(E, [], [data(char_to_string(C))]). :- func tagged_string(string, string) = xml. tagged_string(E, S) = elem(E, [], [data(S)]). %-----------------------------------------------------------------------------% :- func xml_list(string, func(T) = xml, list(T)) = xml. xml_list(Tag, F, L) = elem(Tag, [], list.map(F, L)). %-----------------------------------------------------------------------------% :- func nyi(string) = xml. nyi(Tag) = tagged_string(Tag, "Not yet implemented!"). %-----------------------------------------------------------------------------% :- end_module check_hlds.xml_documentation. %-----------------------------------------------------------------------------%