mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-14 13:23:53 +00:00
e0b6af502d
Estimated hours taken: 1 Branches: main compiler/xml_documentation.m: Add documentation for predicates and functions.
555 lines
19 KiB
Mathematica
555 lines
19 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 2006 The University of Melbourne.
|
|
% 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(module_info::in, io::di, io::uo) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module hlds.hlds_data.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module libs.
|
|
:- import_module libs.compiler_util.
|
|
:- import_module mdbcomp.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module parse_tree.
|
|
:- import_module parse_tree.error_util.
|
|
:- import_module parse_tree.modules.
|
|
:- import_module parse_tree.prog_data.
|
|
:- 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 pair.
|
|
:- import_module string.
|
|
:- import_module svmap.
|
|
:- import_module term.
|
|
:- import_module term_to_xml.
|
|
:- import_module varset.
|
|
|
|
%
|
|
% Record all the locations of comments in a file.
|
|
%
|
|
:- type comments
|
|
---> comments(
|
|
% For each line record what is on the line.
|
|
line_types :: map(int, line_type)
|
|
).
|
|
|
|
:- type line_type
|
|
% A line containing only whitespace.
|
|
---> blank
|
|
|
|
% A line containing just a comment.
|
|
; comment(string)
|
|
|
|
% A line which contains both a comment and code.
|
|
; code_and_comment(string)
|
|
|
|
% A line containing code.
|
|
; code
|
|
.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
xml_documentation(ModuleInfo, !IO) :-
|
|
module_info_get_name(ModuleInfo, ModuleName),
|
|
module_name_to_file_name(ModuleName, ".xml", no, FileName, !IO),
|
|
|
|
lookup_module_source_file(ModuleName, SrcFileName, !IO),
|
|
io.open_input(SrcFileName, SrcResult, !IO),
|
|
(
|
|
SrcResult = ok(SrcStream),
|
|
build_comments(SrcStream, comments(map.init), Comments, !IO),
|
|
|
|
io.open_output(FileName, OpenResult, !IO),
|
|
(
|
|
OpenResult = ok(Stream),
|
|
ModuleInfoXmlDoc = module_info_xml_doc(Comments, ModuleInfo),
|
|
write_xml_doc(Stream, ModuleInfoXmlDoc, !IO)
|
|
;
|
|
OpenResult = error(Err),
|
|
unable_to_open_file(FileName, Err, !IO)
|
|
)
|
|
;
|
|
SrcResult = error(SrcErr),
|
|
unable_to_open_file(SrcFileName, SrcErr, !IO)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
%
|
|
% Given the input_stream build the comments datastructure which
|
|
% represents this stream.
|
|
%
|
|
:- pred build_comments(io.input_stream::in, comments::in, comments::out,
|
|
io::di, io::uo) is det.
|
|
|
|
build_comments(S, comments(!.C), comments(!:C), !IO) :-
|
|
io.get_line_number(S, LineNumber, !IO),
|
|
io.read_line(S, LineResult, !IO),
|
|
(
|
|
LineResult = ok(Line),
|
|
svmap.set(LineNumber, line_type(Line), !C),
|
|
build_comments(S, comments(!.C), comments(!:C), !IO)
|
|
;
|
|
LineResult = eof,
|
|
true
|
|
;
|
|
LineResult = error(E),
|
|
% XXX we should recover more gracefully from this error.
|
|
unexpected(this_file, io.error_message(E))
|
|
).
|
|
|
|
%
|
|
% Given a list of characters representing one line
|
|
% return the type 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 line_type(list(character)) = line_type.
|
|
|
|
line_type(Line) = LineType :-
|
|
list.takewhile(char.is_whitespace, Line, _WhiteSpace, Rest),
|
|
list.takewhile(is_not_comment_char, Rest, Decl, Comment),
|
|
( Rest = [] ->
|
|
LineType = blank
|
|
; Comment = [_ | _] ->
|
|
( Decl = [],
|
|
LineType = comment(string.from_char_list(Comment))
|
|
; Decl = [_ | _],
|
|
LineType = code_and_comment(string.from_char_list(Comment))
|
|
)
|
|
;
|
|
LineType = code
|
|
).
|
|
|
|
:- 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(comments, prog_context, xml) = xml.
|
|
|
|
maybe_add_comment(Comments, Context, Xml) =
|
|
( Xml = elem(N, As, Cs) ->
|
|
( Comment = get_comment(Comments, Context), Comment \= "" ->
|
|
elem(N, As, [elem("comment", [], [data(Comment)]) | Cs])
|
|
;
|
|
Xml
|
|
)
|
|
;
|
|
unexpected(this_file, "maybe_add_comment: not an element")
|
|
).
|
|
|
|
%
|
|
% Get the comment string associated with the given prog_context.
|
|
%
|
|
:- func get_comment(comments, prog_context) = string.
|
|
|
|
get_comment(Comments, 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.
|
|
%
|
|
( comment_on_current_line(Comments, Line, C) ->
|
|
C
|
|
; comment_directly_above(Comments, Line, C) ->
|
|
C
|
|
;
|
|
""
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
%
|
|
% 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(comments::in, int::in, string::out) is semidet.
|
|
|
|
comment_on_current_line(Comments, Line, Comment) :-
|
|
map.search(Comments ^ line_types, Line, code_and_comment(Comment0)),
|
|
RestComment = get_comment_forwards(Comments, 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(comments::in, int::in, string::out) is semidet.
|
|
|
|
comment_directly_above(Comments, Line, Comment) :-
|
|
map.search(Comments ^ line_types, Line - 1, comment(_)),
|
|
Comment = get_comment_backwards(Comments, 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(comments, int) = string.
|
|
|
|
get_comment_forwards(Comments, Line) = Comment :-
|
|
LineType = map.lookup(Comments ^ line_types, Line),
|
|
(
|
|
LineType = comment(CurrentComment),
|
|
CommentBelow = get_comment_backwards(Comments, Line + 1),
|
|
Comment = CurrentComment ++ CommentBelow
|
|
;
|
|
( LineType = blank
|
|
; LineType = code
|
|
; LineType = code_and_comment(_)
|
|
),
|
|
Comment = ""
|
|
).
|
|
|
|
%
|
|
% Return the string which represents the comment ending at the given line.
|
|
% The comment extends backwards until the the line above the given
|
|
% line is not a comment only line.
|
|
%
|
|
:- func get_comment_backwards(comments, int) = string.
|
|
|
|
get_comment_backwards(Comments, Line) = Comment :-
|
|
LineType = map.lookup(Comments ^ line_types, Line),
|
|
(
|
|
LineType = comment(CurrentComment),
|
|
CommentAbove = get_comment_backwards(Comments, Line - 1),
|
|
Comment = CommentAbove ++ CurrentComment
|
|
;
|
|
( LineType = blank
|
|
; LineType = code
|
|
; LineType = code_and_comment(_)
|
|
),
|
|
Comment = ""
|
|
).
|
|
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type module_info_xml_doc
|
|
---> module_info_xml_doc(comments, module_info).
|
|
|
|
:- instance xmlable(module_info_xml_doc) where [
|
|
(to_xml(module_info_xml_doc(Comments, ModuleInfo)) = Xml :-
|
|
module_info_get_type_table(ModuleInfo, TypeTable),
|
|
map.foldl(type_documentation(Comments), TypeTable, [], TypeXmls),
|
|
TypeXml = elem("types", [], TypeXmls),
|
|
|
|
module_info_preds(ModuleInfo, PredTable),
|
|
map.foldl(pred_documentation(Comments), PredTable, [], PredXmls),
|
|
PredXml = elem("preds", [], PredXmls),
|
|
|
|
Xml = elem("module", [], [TypeXml, PredXml])
|
|
)
|
|
].
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
%
|
|
% Output the documentation of one type.
|
|
%
|
|
:- pred type_documentation(comments::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, ImportStatus),
|
|
|
|
( status_defined_in_this_module(ImportStatus) = 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(TypeName),
|
|
XmlTypeParams = xml_list("type_params", type_param(TVarset), TParams),
|
|
|
|
Tag = type_xml_tag(TypeBody),
|
|
Id = attr("id", sym_name_and_arity_to_id("type", TypeName, TypeArity)),
|
|
Children = [XmlName, XmlTypeParams, prog_context(Context) |
|
|
type_body(C, TVarset, TypeBody)],
|
|
Xml0 = elem(Tag, [Id], Children),
|
|
Xml = maybe_add_comment(C, Context, Xml0),
|
|
|
|
!:Xmls = [Xml | !.Xmls]
|
|
;
|
|
true
|
|
).
|
|
|
|
:- 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(tvarset, type_param) = xml.
|
|
|
|
type_param(TVarset, TVar) = Xml :-
|
|
TVarName = varset.lookup_name(TVarset, TVar),
|
|
Xml = tagged_string("type_variable", TVarName).
|
|
|
|
:- func type_body(comments, tvarset, hlds_type_body) = list(xml).
|
|
|
|
type_body(C, TVarset, hlds_du_type(Ctors, _, _, _, _, _)) =
|
|
[xml_list("constructors", constructor(C, TVarset), Ctors)].
|
|
type_body(_, TVarset, hlds_eqv_type(Type)) =
|
|
[elem("equivalent_type", [], [mer_type(TVarset, Type)])].
|
|
|
|
% XXX TODO
|
|
type_body(_, _, hlds_foreign_type(_)) = [nyi("hlds_foreign_type")].
|
|
type_body(_, _, hlds_solver_type(_, _)) = [nyi("hlds_solver_type")].
|
|
type_body(_, _, hlds_abstract_type(_)) = [nyi("hlds_abstract_type")].
|
|
|
|
|
|
:- func constructor(comments, tvarset, constructor) = xml.
|
|
|
|
constructor(C, TVarset,
|
|
ctor(Exists, Constraints, Name, Args, Context)) = Xml :-
|
|
Id = attr("id", sym_name_and_arity_to_id("ctor", Name, length(Args))),
|
|
XmlName = name(Name),
|
|
XmlContext = prog_context(Context),
|
|
XmlArgs = xml_list("ctor_args", constructor_arg(C, TVarset), Args),
|
|
XmlExistVars = xml_list("ctor_exist_vars", type_param(TVarset), Exists),
|
|
XmlConstraints =
|
|
xml_list("ctor_constraints", prog_constraint(TVarset), Constraints),
|
|
Xml0 = elem("constructor", [Id],
|
|
[XmlName, XmlContext, XmlArgs, XmlExistVars, XmlConstraints]),
|
|
Xml = maybe_add_comment(C, Context, Xml0).
|
|
|
|
:- func constructor_arg(comments, tvarset, constructor_arg) = xml.
|
|
|
|
constructor_arg(C, TVarset, ctor_arg(MaybeFieldName, Type, Context)) = Xml :-
|
|
XmlType = elem("arg_type", [], [mer_type(TVarset, Type)]),
|
|
XmlContext = prog_context(Context),
|
|
(
|
|
MaybeFieldName = yes(FieldName),
|
|
Id = attr("id", sym_name_to_id("field", FieldName)),
|
|
XmlMaybeFieldName = [elem("field", [Id], [name(FieldName)])]
|
|
;
|
|
MaybeFieldName = no,
|
|
XmlMaybeFieldName = []
|
|
),
|
|
|
|
Xml0 = elem("ctor_arg", [], [XmlType, XmlContext | XmlMaybeFieldName]),
|
|
Xml = maybe_add_comment(C, Context, Xml0).
|
|
|
|
:- func mer_type(tvarset, mer_type) = xml.
|
|
|
|
mer_type(TVarset, type_variable(TVar, _)) = type_param(TVarset, TVar).
|
|
mer_type(TVarset, defined_type(TypeName, Args, _)) = Xml :-
|
|
Ref = attr("ref", sym_name_and_arity_to_id("type", TypeName, length(Args))),
|
|
XmlName = name(TypeName),
|
|
XmlArgs = xml_list("type_args", mer_type(TVarset), Args),
|
|
Xml = elem("type", [Ref], [XmlName, XmlArgs]).
|
|
mer_type(_, builtin_type(builtin_type_int)) = elem("int", [], []).
|
|
mer_type(_, builtin_type(builtin_type_float)) = elem("float", [], []).
|
|
mer_type(_, builtin_type(builtin_type_string)) = elem("string", [], []).
|
|
mer_type(_, builtin_type(builtin_type_character)) = elem("character", [], []).
|
|
mer_type(_, higher_order_type(_, _, _, _)) = nyi("higher_order_type").
|
|
mer_type(_, tuple_type(_, _)) = nyi("tuple_type").
|
|
mer_type(_, apply_n_type(_, _, _)) = nyi("apply_n_type").
|
|
mer_type(_, kinded_type(_, _)) = nyi("kinded_type").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred pred_documentation(comments::in, pred_id::in, pred_info::in,
|
|
list(xml)::in, list(xml)::out) is det.
|
|
|
|
pred_documentation(C, _PredId, PredInfo, !Xml) :-
|
|
pred_info_get_import_status(PredInfo, ImportStatus),
|
|
pred_info_get_origin(PredInfo, Origin),
|
|
|
|
(
|
|
status_defined_in_this_module(ImportStatus) = yes,
|
|
Origin = origin_user(_)
|
|
->
|
|
Module = pred_info_module(PredInfo),
|
|
Name = pred_info_name(PredInfo),
|
|
PredName = qualified(Module, Name),
|
|
|
|
Arity = pred_info_orig_arity(PredInfo),
|
|
pred_info_context(PredInfo, Context),
|
|
IsPredOrFunc = pred_info_is_pred_or_func(PredInfo),
|
|
|
|
pred_info_get_typevarset(PredInfo, TVarset),
|
|
pred_info_get_arg_types(PredInfo, Types),
|
|
|
|
pred_info_get_exist_quant_tvars(PredInfo, Exists),
|
|
pred_info_get_class_context(PredInfo, Constraints),
|
|
|
|
(
|
|
IsPredOrFunc = predicate,
|
|
Tag = "predicate"
|
|
;
|
|
IsPredOrFunc = function,
|
|
Tag = "function"
|
|
),
|
|
Id = sym_name_and_arity_to_id(Tag, PredName, Arity),
|
|
|
|
XmlName = name(qualified(Module, Name)),
|
|
XmlContext = prog_context(Context),
|
|
XmlTypes = xml_list("pred_types", mer_type(TVarset), Types),
|
|
XmlExistVars = xml_list("pred_exist_vars", type_param(TVarset), Exists),
|
|
XmlConstraints = prog_constraints(TVarset, Constraints),
|
|
|
|
Xml0 = elem(Tag, [attr("id", Id)],
|
|
[XmlName, XmlTypes, XmlContext, XmlExistVars, XmlConstraints]),
|
|
|
|
Xml = maybe_add_comment(C, Context, Xml0),
|
|
|
|
!:Xml = [Xml | !.Xml]
|
|
;
|
|
true
|
|
).
|
|
|
|
:- func prog_constraints(tvarset, prog_constraints) = xml.
|
|
|
|
prog_constraints(TVarset, constraints(Univs, Exists)) = Xml :-
|
|
XmlUnivs = xml_list("pred_universal", prog_constraint(TVarset), Univs),
|
|
XmlExists = xml_list("pred_exist", prog_constraint(TVarset), Exists),
|
|
|
|
Xml = elem("pred_constraints", [], [XmlUnivs, XmlExists]).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- func name(sym_name) = xml.
|
|
|
|
name(unqualified(Name)) = tagged_string("unqualified", Name).
|
|
name(qualified(Module, Name)) =
|
|
elem("qualified", [], [
|
|
tagged_string("module", sym_name_to_string(Module)),
|
|
tagged_string("name", Name)]).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- func prog_context(prog_context) = xml.
|
|
|
|
prog_context(context(FileName, LineNumber)) =
|
|
elem("context", [], [
|
|
tagged_string("filename", FileName),
|
|
tagged_int("line", LineNumber)]).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- func prog_constraint(tvarset, prog_constraint) = xml.
|
|
|
|
prog_constraint(TVarset, constraint(ClassName, Types)) = Xml :-
|
|
Id = sym_name_and_arity_to_id("constraint", ClassName, list.length(Types)),
|
|
XmlName = name(ClassName),
|
|
XmlTypes = xml_list("constraint_types", mer_type(TVarset), Types),
|
|
Xml = elem("constraint", [attr("ref", Id)], [XmlName, XmlTypes]).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
%
|
|
% 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_and_arity_to_id(string, sym_name, int) = string.
|
|
|
|
sym_name_and_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_string(string, string) = xml.
|
|
|
|
tagged_string(E, S) = elem(E, [], [data(S)]).
|
|
|
|
:- func tagged_int(string, int) = xml.
|
|
|
|
tagged_int(E, I) = elem(E, [], [data(int_to_string(I))]).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- 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!").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- func this_file = string.
|
|
|
|
this_file = "xml_documentation.m".
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|