[m-rev.] For review: use XML browser to browse terms in mdb
Ian MacLarty
maclarty at cs.mu.OZ.AU
Thu Dec 9 03:00:56 AEDT 2004
For review by anyone.
Estimated hours taken: 15
Branches: main
Allow custom functor to element mappings in term_to_xml library.
Add --dump-xml-hlds option to compiler to dump the HLDS in XML format (thanks
to Julien).
Allow terms to be saved as XML in mdb and allow an XML browser to be invoked on
browsable objects in mdb. The user can set two options which control where the
XML is dumped and the command used to browse the XML. The defaults assume
xsltproc and mozilla are installed.
Disable setting of the `field' attribute in generated XML until a bug in the
runtime system has been fixed. The bug causes a seg fault when
construct.get_functor is called on a functor with an existentially quantified
argument type.
Add a check to see if a DTD can be generated for a type under a custom mapping
scheme. This involves check that the mapping scheme does not generate the same
element for any two distinct functors that could appear in ground terms of
the type.
browser/browse.m
Add a predicate to save a browser term as XML to a file.
compiler/mercury_compile.m
Handle --dump-xml-hlds option.
compiler/options.m
Add --dump-xml-hlds option.
doc/user_guide.texi
Document new --xml option for the mdb `browse' command.
Document new --xml option for the mdb `save_to_file' command.
Document the `set xml_tmp_filename' and `set xml_browser_cmd' commands.
extras/xml_stylesheets/xul_tree.xsl
Hide the field name by default (since we don't populate this attribute
at the moment).
Fix a bug where quotes were not being printed around strings.
The `typename' attribute has now become simply `type'.
library/term_to_xml.m
Allow custom functor to element mappings and include two predefined
mappings.
Do not call construct.get_functor when writing out an XML document so
that the previously mentioned runtime bug doesn't bite. This is one
line of code that just needs to be uncommented when the bug is fixed -
the line is responsible for getting the field names of the arguments of
a functor.
Check that a mapping scheme cannot assign the same element to
two different functors when a DTD is requested.
scripts/Mmakefile
Copy extras/xml_stylesheets/xul_tree.xsl to the mdb install
directory so it can be used by the default xml browser command.
scripts/mdbrc.in
Set default values for xml_browser_cmd and xml_tmp_filename.
tests/debugger/browser_test.inp
tests/debugger/browser_test.exp
Test --xml option for `browse' command.
tests/hard_coded/write_xml.m
tests/hard_coded/write_xml.exp
Test custom and predefined mapping schemes.
trace/mercury_trace_browse.c
trace/mercury_trace_browse.h
Add functions to save a term as XML to a file and then
invoke the user's XML browser.
trace/mercury_trace_internal.c
Add --xml option to `browse' and `save_to_file' mdb commands.
Index: browser/browse.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/browse.m,v
retrieving revision 1.47
diff -u -r1.47 browse.m
--- browser/browse.m 5 Nov 2004 06:30:19 -0000 1.47
+++ browser/browse.m 8 Dec 2004 14:37:06 -0000
@@ -94,6 +94,13 @@
:- pred save_term_to_file(string::in, string::in, browser_term::in,
io__output_stream::in, io::di, io::uo) is cc_multi.
+ % save_term_to_file_xml(FileName, BrowserTerm, Out, !IO):
+ % Save BrowserTerm to FileName as an XML document. If there
+ % is an error, print an error message to Out.
+ %
+:- pred save_term_to_file_xml(string::in, browser_term::in,
+ io__output_stream::in, io::di, io::uo) is cc_multi.
+
%---------------------------------------------------------------------------%
:- implementation.
@@ -103,7 +110,7 @@
:- import_module mdb__frame.
:- import_module mdb__sized_pretty.
-:- import_module bool, string, int, char, map, std_util.
+:- import_module bool, string, int, char, map, std_util, term_to_xml.
:- import_module parser, require, pprint, getopt, deconstruct.
%---------------------------------------------------------------------------%
@@ -126,6 +133,9 @@
:- pragma export(save_term_to_file(in, in, in, in, di, uo),
"ML_BROWSE_save_term_to_file").
+:- pragma export(save_term_to_file_xml(in, in, in, di, uo),
+ "ML_BROWSE_save_term_to_file_xml").
+
%---------------------------------------------------------------------------%
%
% If the term browser is called from the internal debugger, input is
@@ -176,6 +186,49 @@
io__write_string("=\n", !IO),
save_univ(1, Result, !IO),
io__write_string("\n", !IO)
+ )
+ ),
+ io__told(!IO)
+ ;
+ FileStreamRes = error(Error),
+ io__error_message(Error, Msg),
+ io__write_string(OutStream, Msg, !IO)
+ ).
+
+:- type xml_predicate_wrapper
+ ---> predicate(
+ predicate_name :: string,
+ predicate_arguments :: list(univ)
+ ).
+
+:- type xml_function_wrapper
+ ---> function(
+ function_name :: string,
+ function_arguments :: list(univ),
+ return_value :: univ
+ ).
+
+save_term_to_file_xml(FileName, BrowserTerm, OutStream, !IO) :-
+ io__tell(FileName, FileStreamRes, !IO),
+ (
+ FileStreamRes = ok,
+ (
+ BrowserTerm = plain_term(Univ),
+ Term = univ_value(Univ),
+ term_to_xml.write_xml_doc_cc(Term, simple,
+ no_stylesheet, no_dtd, _, !IO)
+ ;
+ BrowserTerm = synthetic_term(Functor, Args, MaybeRes),
+ (
+ MaybeRes = no,
+ PredicateTerm = predicate(Functor, Args),
+ term_to_xml.write_xml_doc_cc(PredicateTerm,
+ simple, no_stylesheet, no_dtd, _, !IO)
+ ;
+ MaybeRes = yes(Result),
+ FunctionTerm = function(Functor, Args, Result),
+ term_to_xml.write_xml_doc_cc(FunctionTerm,
+ simple, no_stylesheet, no_dtd, _, !IO)
)
),
io__told(!IO)
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.316
diff -u -r1.316 mercury_compile.m
--- compiler/mercury_compile.m 20 Oct 2004 09:44:57 -0000 1.316
+++ compiler/mercury_compile.m 8 Dec 2004 14:37:06 -0000
@@ -168,6 +168,7 @@
:- import_module library, getopt, set_bbbtree, term, varset, assoc_list.
:- import_module gc.
:- import_module pprint.
+:- import_module term_to_xml.
%-----------------------------------------------------------------------------%
@@ -4336,6 +4337,25 @@
string__append_list(["can't open file `",
DumpFile, "' for output."], ErrorMessage),
report_error(ErrorMessage, !IO)
+ ),
+ globals.io_lookup_bool_option(dump_xml_hlds, DumpXML, !IO),
+ ( DumpXML = yes ->
+ io__open_output(DumpFile ++ ".xml", XMLRes, !IO),
+ maybe_write_string(Verbose, "% Dump out HLDSXML ...\n", !IO),
+ ( XMLRes = ok(XMLFileStream) ->
+ term_to_xml__write_xml_doc(XMLFileStream, HLDS, simple,
+ no_stylesheet, no_dtd, _, !IO),
+ io__close_output(XMLFileStream, !IO),
+ maybe_write_string(Verbose, " done.\n", !IO)
+ ;
+ maybe_write_string(Verbose, "\n", !IO),
+ string__append_list(["can't open file `",
+ DumpFile ++ ".xml",
+ "' for output."], XMLErrorMessage),
+ report_error(XMLErrorMessage, !IO)
+ )
+ ;
+ true
).
:- pred mercury_compile__maybe_dump_mlds(mlds::in, int::in, string::in,
Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.437
diff -u -r1.437 options.m
--- compiler/options.m 30 Nov 2004 06:54:32 -0000 1.437
+++ compiler/options.m 8 Dec 2004 14:37:06 -0000
@@ -163,6 +163,7 @@
; auto_comments
; show_dependency_graph
; dump_hlds
+ ; dump_xml_hlds
; dump_hlds_pred_id
; dump_hlds_alias
; dump_hlds_options
@@ -828,6 +829,7 @@
auto_comments - bool(no),
show_dependency_graph - bool(no),
dump_hlds - accumulating([]),
+ dump_xml_hlds - bool(no),
dump_hlds_pred_id - int(-1),
dump_hlds_alias - string(""),
dump_hlds_options - string(""),
@@ -1478,6 +1480,7 @@
long_option("auto-comments", auto_comments).
long_option("show-dependency-graph", show_dependency_graph).
long_option("dump-hlds", dump_hlds).
+long_option("dump-xml-hlds", dump_xml_hlds).
long_option("hlds-dump", dump_hlds).
long_option("dump-hlds-pred-id", dump_hlds_pred_id).
long_option("dump-hlds-alias", dump_hlds_alias).
Index: doc/user_guide.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/user_guide.texi,v
retrieving revision 1.398
diff -u -r1.398 user_guide.texi
--- doc/user_guide.texi 19 Nov 2004 11:54:21 -0000 1.398
+++ doc/user_guide.texi 8 Dec 2004 14:54:54 -0000
@@ -2527,8 +2527,8 @@
@c The options @samp{-f} or @samp{--flat}, @samp{-p} or @samp{--pretty},
@c and @samp{-v} or @samp{--verbose} specify the format to use for printing.
@sp 1
- at item browse [-fpv] @var{name}
- at itemx browse [-fpv] @var{num}
+ at item browse [-fpvx] @var{name}
+ at itemx browse [-fpvx] @var{num}
@kindex browse (mdb command)
Invokes an interactive term browser to browse
the value of the variable in the current environment
@@ -2543,42 +2543,65 @@
@sp 1
The options @samp{-f} or @samp{--flat}, @samp{-p} or @samp{--pretty},
and @samp{-v} or @samp{--verbose} specify the format to use for browsing.
+The @samp{-x} or @samp{--xml} option tells mdb to dump the value of the
+variable to an XML file and then invoke an XML browser on the file.
+The XML filename as well as the command to invoke the XML browser can
+be set using the @samp{set} command. See the documentation for @samp{set}
+for more details.
@sp 1
For further documentation on the interactive term browser,
invoke the @samp{browse} command from within @samp{mdb} and then
type @samp{help} at the @samp{browser>} prompt.
@sp 1
- at item browse [-fpv]
- at itemx browse [-fpv] goal
+ at item browse [-fpvx]
+ at itemx browse [-fpvx] goal
Invokes the interactive term browser to browse
the goal of the current call in its present state of instantiation.
@sp 1
The options @samp{-f} or @samp{--flat}, @samp{-p} or @samp{--pretty},
and @samp{-v} or @samp{--verbose} specify the format to use for browsing.
+The @samp{-x} or @samp{--xml} option tells mdb to dump the goal to an XML file
+and then invoke an XML browser on the file. The XML filename as well as the
+command to invoke the XML browser can be set using the @samp{set} command. See
+the documentation for @samp{set} for more details.
@sp 1
- at item browse [-fpv] exception
+ at item browse [-fpvx] exception
Invokes the interactive term browser to browse
the value of the exception at an EXCP port.
Reports an error if the current event does not refer to such a port.
@sp 1
The options @samp{-f} or @samp{--flat}, @samp{-p} or @samp{--pretty},
and @samp{-v} or @samp{--verbose} specify the format to use for browsing.
+The @samp{-x} or @samp{--xml} option tells mdb to dump the exception to an
+XML file and then invoke an XML browser on the file. The XML filename as well
+as the command to invoke the XML browser can be set using the @samp{set}
+command. See the documentation for @samp{set} for more details.
@sp 1
- at item browse [-fpv] action @var{num}
+ at item browse [-fpvx] action @var{num}
Invokes an interactive term browser to browse a representation
of the @var{num}'th I/O action executed by the program.
@sp 1
The options @samp{-f} or @samp{--flat}, @samp{-p} or @samp{--pretty},
and @samp{-v} or @samp{--verbose} specify the format to use for browsing.
+The @samp{-x} or @samp{--xml} option tells mdb to dump the io action
+representation to an XML file and then invoke an XML browser on the file. The
+XML filename as well as the command to invoke the XML browser can be set using
+the @samp{set} command. See the documentation for @samp{set} for more details.
@c @sp 1
- at c @item browse [-fpv] proc_body
+ at c @item browse [-fpvx] proc_body
@c Invokes an interactive term browser to browse a representation
@c of the body of the current procedure, if it is available.
@c @sp 1
@c The options @samp{-f} or @samp{--flat}, @samp{-p} or @samp{--pretty},
@c and @samp{-v} or @samp{--verbose} specify the format to use for browsing.
+ at c The @samp{-x} or @samp{--xml} option tells mdb to dump the procedure
+ at c body representation to an XML file and then invoke an XML browser on the
+ at c file. The XML filename as well as the command to invoke the XML
+ at c browser can be set using the @samp{set} command. See the documentation
+ at c for @samp{set} for more details.
@sp 1
- at item stack [-d] [@var{num}]
+
+ at item stack [-d] [@var{num}]
@kindex stack (mdb command)
Prints the names of the ancestors of the call
specified by the current event.
@@ -2664,9 +2687,12 @@
@kindex size (mdb command)
@kindex width (mdb command)
@kindex lines (mdb command)
+ at kindex xml_browser_cmd (mdb command)
+ at kindex xml_tmp_filename (mdb command)
Updates the configuration parameters of the browser.
The parameters that can be configured are
- at samp{format}, @samp{depth}, @samp{size}, @samp{width} and @samp{lines}.
+ at samp{format}, @samp{depth}, @samp{size}, @samp{width}, @samp{lines},
+ at samp{xml_browser_cmd} and @samp{xml_tmp_filename}.
@sp 1
@itemize @bullet
@item
@@ -2698,6 +2724,19 @@
@sp 1
@item
@samp{lines} is the maximum number of lines of one term to display.
+ at sp 1
+ at item
+ at samp{xml_tmp_filename} is the name of the file to dump XML to before
+invoking your XML browser.
+on
+ at sp 1
+ at item
+ at samp{xml_browser_cmd} is the shell command used to invoke your xml browser.
+By default the program @samp{xsltproc} is invoked to apply the
+xul_tree.xsl stylesheet in extras/xml_stylesheets, then @samp{mozilla} is
+invoked on the resulting XUL file. You can use the apostrophe character (')
+to quote the command string when using the @samp{set} command, for example
+"set xml_browser_cmd 'firefox file:///tmp/mdbtmp.xml'".
@end itemize
@sp 1
The browser maintains separate configuration parameters
@@ -2782,26 +2821,31 @@
The option @samp{-t} (or @samp{--timeout}) specifies
the maximum number of seconds to wait for the server to start.
@sp 1
- at item save_to_file goal @var{filename}
+ at item save_to_file [-x] goal @var{filename}
@kindex save_to_file (mdb command)
Writes the goal of the current call in its present state of instantiation
-to the specified file.
+to the specified file. The option @samp{-x} (or @samp{--xml}) causes the
+output to be in XML.
@sp 1
- at item save_to_file exception @var{filename}
+ at item save_to_file [-x] exception @var{filename}
Writes the value of the exception at an EXCP port
to the specified file.
Reports an error if the current event does not refer to such a port.
+The option @samp{-x} (or @samp{--xml}) causes the
+output to be in XML.
@sp 1
- at item save_to_file @var{name} @var{filename}
- at itemx save_to_file @var{num} @var{filename}
+ at item save_to_file [-x] @var{name} @var{filename}
+ at itemx save_to_file [-x] @var{num} @var{filename}
Writes the value of the variable in the current environment
with the given ordinal number or with the given name
-to the specified file.
+to the specified file. The option @samp{-x} (or @samp{--xml}) causes the
+output to be in XML.
@c @sp 1
- at c @item save_to_file proc_body @var{filename}
+ at c @item save_to_file [-x] proc_body @var{filename}
@c Writes the representation of the body of the current procedure,
@c if it is available,
- at c to the specified file.
+ at c to the specified file. The option @samp{-x} (or @samp{--xml}) causes the
+ at c output to be in XML.
@end table
@sp 1
Index: extras/xml_stylesheets/xul_tree.xsl
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/xml_stylesheets/xul_tree.xsl,v
retrieving revision 1.1
diff -u -r1.1 xul_tree.xsl
--- extras/xml_stylesheets/xul_tree.xsl 7 Dec 2004 04:55:49 -0000 1.1
+++ extras/xml_stylesheets/xul_tree.xsl 8 Dec 2004 14:37:06 -0000
@@ -32,6 +32,7 @@
<xsl:attribute name="id">field</xsl:attribute>
<xsl:attribute name="label">Field Name</xsl:attribute>
<xsl:attribute name="flex">1</xsl:attribute>
+ <xsl:attribute name="hidden">true</xsl:attribute>
</xsl:element>
<xsl:element name="splitter">
<xsl:attribute name="class">tree-splitter</xsl:attribute>
@@ -82,7 +83,7 @@
<xsl:element name="treerow">
<xsl:element name="treecell">
<xsl:choose>
- <xsl:when test="@name='String'">
+ <xsl:when test="name()='String'">
<xsl:attribute name="label">"<xsl:value-of select="." />"</xsl:attribute>
</xsl:when>
<xsl:otherwise>
@@ -96,7 +97,7 @@
</xsl:attribute>
</xsl:element>
<xsl:element name="treecell">
- <xsl:attribute name="label">string</xsl:attribute>
+ <xsl:attribute name="label"><xsl:value-of select="@type" /></xsl:attribute>
</xsl:element>
<xsl:element name="treecell">
<xsl:attribute name="label">
@@ -162,7 +163,7 @@
</xsl:element>
<xsl:element name="treecell">
<xsl:attribute name="label">
- <xsl:value-of select="@typename" />
+ <xsl:value-of select="@type" />
</xsl:attribute>
</xsl:element>
<xsl:element name="treecell">
Index: library/term_to_xml.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/term_to_xml.m,v
retrieving revision 1.1
diff -u -r1.1 term_to_xml.m
--- library/term_to_xml.m 7 Dec 2004 04:55:49 -0000 1.1
+++ library/term_to_xml.m 8 Dec 2004 14:37:06 -0000
@@ -14,31 +14,25 @@
% an output stream as XML.
%
% Each functor in a term is given a corresponding well-formed element name
-% in the XML document.
+% in the XML document according to a mapping. Some predefined mappings are
+% prodice, but user defined mappings may also be used.
%
-% The element names `String', `Int', `Char' and `Float' are reserved for the
-% corresponding Mercury builtin types. The values for these elements are
-% stored as parsed characater data inside the element.
-%
-% Elements for discriminated unions get their name from the functor name and
-% the type name. Array element names consist of the string "Array--" followed
-% by the type name of the elements of the array. All other types are assigned
-% the reserved `Unrecognised' element name.
-%
-% Each element (including `Unrecognised') may also have certain attributes set:
+% The following attributes can be set for each XML element:
%
% functor - the original functor name as returned by
-% deconstruct.deconstruct/5. This attribute will be present for
-% every element except elements for builtin types.
-%
-% typename - the type name of the Mercury type the element represents.
-% This attribute will also always be present for all elements except
-% elements for builtin types.
+% deconstruct.deconstruct/5.
+%
+% arity - the arity of the functor as returned by deconstruct.deconstruct/5.
+%
+% type - the type name of the Mercury type the element represents.
+%
+% field - the field name of a discriminated union functor argument if it has
+% one. XXX Currently field attribute values are not set because of a bug
+% in the runtime system.
%
-% field - discriminated union functor arguments (including those with a
-% builtin type) that have a field name will have this attribute set.
+% The names of the above attributes can also be customized.
%
-% The XML document can also be annotated with a stylesheet reference. Once a
+% The XML document can be annotated with a stylesheet reference. Once a
% Mercury term is in XML it can be converted to many different formats using
% the appropriate stylesheet. For example in the extras/xml_stylesheets
% distribution there are stylesheets to convert XML documents generated with
@@ -47,6 +41,21 @@
%
% To support third parties generating XML which is compatible with the XML
% generated by this library, a DTD for a Mercury type can also be generated.
+% A DTD for a given type and functo-to-element mapping may be generated
+% provided the following conditions hold:
+%
+% 1. If the type is a discriminated union then there must be only
+% one top-level functor for the type. This is because the top
+% level functor will be used to generate the document type name.
+%
+% 2. The provided functor to element mapping must map each functor
+% to a unique element name for every functor that could appear in
+% terms of the type.
+%
+% 3. Only types whose terms consist of discriminated unions, arrays
+% and the builtin types `int', `string', `character' and `float' can be
+% used to automatically generate DTDs. This list may be extended in the
+% future.
%
% The generated DTD is also a good reference when creating a stylesheet as
% it contains comments describing the mapping from functors to elements.
@@ -57,17 +66,10 @@
:- module term_to_xml.
:- interface.
-:- import_module io, int, deconstruct, std_util.
+:- import_module io, int, deconstruct, std_util, list.
%-----------------------------------------------------------------------------%
-:- type maybe_stylesheet
- ---> with_stylesheet(
- stylesheet_type :: string,
- stylesheet_href :: string
- )
- ; no_stylesheet.
-
% Values of this type specify the DOCTYPE of an XML document when
% the DOCTYPE is defined by an external DTD.
%
@@ -87,170 +89,342 @@
% Do not include any DOCTYPE information.
; no_dtd.
+ % Values of this type indicate whether a stylesheet reference should be
+ % included in a generated XML document.
+:- type maybe_stylesheet
+ ---> with_stylesheet(
+ stylesheet_type :: string, % For example "text/xsl"
+ stylesheet_href :: string
+ )
+ ; no_stylesheet.
+
% Values of this type indicate whether a DTD was successfully
% generated or not. A DTD cannot be generated for a type with more
% than one top-level functor since only one root element can be
- % specified by a DTD.
+ % specified by a DTD. A DTD also cannot be generated for a
+ % type where the mapping from functors of the type to
+ % elements is not unique (since then the legal children DTD rules
+ % cannot be expressed properly).
%
:- type dtd_generation_result
---> ok
- ; multiple_functors_for_root.
-
- % write_xml_doc(Term, MaybeStyleSheet, MaybeDTD, DTDResult, !IO).
- % Write Term to the current output stream as an XML document.
+ % The root type is a discriminated union with
+ % multiple functors.
+ %
+ ; multiple_functors_for_root
+
+ % The functor-to-element mapping maps different
+ % functors to the same element. The duplicate element
+ % and a list of types whose functors map to that
+ % element is given.
+ %
+ ; duplicate_elements(
+ duplicate_element :: string,
+ duplicate_types :: list(type_desc)
+ )
+ ;
+ % At the moment we only support generation of DTDs for
+ % types made up of discriminated unions, arrays,
+ % strings, ints, characters and floats.
+ %
+ unsupported_dtd_type(type_desc).
+
+ % Values of this type specify what mapping from functors to elements
+ % to use when generating XML. The role of a mapping is two fold:
+ % 1. To map functors to elements, and
+ % 2. To map functors to a set of attributes that should be
+ % set for the corresponding element.
+ %
+ % We provide two predefined mappings:
+ %
+ % 1. simple: The functors `[]', `[|]' and `{}' are mapped to the
+ % elements `List', `Nil' and `Tuple' respectively. Arrays are
+ % assigned the `Array' element. The builtin types are assigned
+ % the elements `Int', `String', `Float' and `Char'. All other
+ % functors are assigned elements with the same name as the
+ % functor provided the funtor name is well formed and does
+ % not start with a capital letter. Otherwise a mangled
+ % version of the functor name is used.
+ %
+ % All elements except `Int', `String', `Float' and `Char'
+ % will have their `functor', `arity', `type' and `field' (if
+ % there is a field name) attrinutes set. `Int', `String',
+ % `Float' and `Char' elements will just have their `type' and
+ % possibly their `field' attributes set.
+ %
+ % The `simple' mapping is designed to be easy to read and use,
+ % but may result in the same element being assigned to different
+ % functors.
+ %
+ % 2. unique: Here we use the same mapping as `simple' except
+ % we append the fuctor arity for discriminated unions and
+ % a mangled version of the type name for every element. The same
+ % attributes as the `simple' scheme are provided. The advantage
+ % of this scheme is that it maps each functor to a unique
+ % element. This means that it will always be possible to
+ % generate a DTD using this mapping so long as there is only
+ % one top level functor and no unsupported types can appear in
+ % terms of the type.
+ %
+ % A custom mapping can be provided using the `custom' functor. See the
+ % documentation for the element_pred type below for more information.
+ %
+:- type element_mapping
+ ---> simple
+ ; unique
+ ; custom(element_pred).
+
+:- inst element_mapping
+ ---> simple
+ ; unique
+ ; custom(element_pred).
+
+ % write_xml_doc(Term, ElementMapping, MaybeStyleSheet, MaybeDTD,
+ % DTDResult, !IO).
+ % Write Term to the current output stream as an XML document using
+ % ElementMapping as the scheme to map functors to elements.
% MaybeStyleSheet and MaybeDTD specify whether or not a stylesheet
% reference and/or a DTD should be included. Any non-canonical terms
- % will be canonicalized. If an embedded DTD was requested and the type
- % has more than one top level functor then multiple_functors_for_root
- % will be returned in DTDResult and nothing will be written.
+ % will be canonicalized. If an embedded DTD is requested, but it is
+ % not possible to generated a DTD for Term using ElementMapping, then a
+ % value other than `ok' is returned in DTDResult and nothing is written
+ % out. See the documentatin of the dtd_generation_result type for more
+ % information of DTDResult when it is not `ok'.
%
-:- pred write_xml_doc(T::in, maybe_stylesheet::in, maybe_dtd::in,
+:- pred write_xml_doc(T::in, element_mapping::in(element_mapping),
+ maybe_stylesheet::in, maybe_dtd::in,
dtd_generation_result::out, io::di, io::uo) is det.
- % write_xml_doc(Stream, Term, MaybeStyleSheet, MaybeDTD, DTDResult,
- % !IO).
- % Same as write_xml_doc/5 except write the XML doc to the given
+ % write_xml_doc(Stream, Term, ElementMapping, MaybeStyleSheet,
+ % MaybeDTD, DTDResult, !IO).
+ % Same as write_xml_doc/7 except write the XML doc to the given
% output stream.
%
-:- pred write_xml_doc(io.output_stream::in, T::in, maybe_stylesheet::in,
+:- pred write_xml_doc(io.output_stream::in, T::in,
+ element_mapping::in(element_mapping), maybe_stylesheet::in,
maybe_dtd::in, dtd_generation_result::out, io::di, io::uo) is det.
- % write_xml_doc_cc(Term, MaybeStyleSheet, MaybeDTD, DTDResult, !IO).
- % Write Term to the current output stream as an XML document.
+ % write_xml_doc_cc(Term, ElementMapping, MaybeStyleSheet, MaybeDTD,
+ % DTDResult, !IO).
+ % Write Term to the current output stream as an XML document using
+ % ElementMapping as the scheme to map functors to elements.
% MaybeStyleSheet and MaybeDTD specify whether or not a stylesheet
% reference and/or a DTD should be included. Any non-canonical terms
- % will be be written out in full. If an embedded DTD was requested and
- % the type has more than one top level functor then
- % multiple_functors_for_root will be returned in DTDResult and nothing
- % will be written.
- %
-:- pred write_xml_doc_cc(T::in, maybe_stylesheet::in, maybe_dtd::in,
- dtd_generation_result::out, io::di, io::uo) is cc_multi.
-
- % write_xml_doc_cc(Stream, Term, MaybeStyleSheet, MaybeDTD, DTDResult,
- % !IO).
- % Same as write_xml_doc/5 except write the XML doc to the given
+ % will be be written out in full. If an embedded DTD is requested, but
+ % it is not possible to generated a DTD for Term using ElementMapping,
+ % then a value other than `ok' is returned in DTDResult and nothing is
+ % written out. See the documentatin of the dtd_generation_result type
+ % for more information on the meaning of DTDResult when it is not `ok'.
+ %
+:- pred write_xml_doc_cc(T::in, element_mapping::in(element_mapping),
+ maybe_stylesheet::in, maybe_dtd::in, dtd_generation_result::out,
+ io::di, io::uo) is cc_multi.
+
+ % write_xml_doc_cc(Stream, Term, ElementMapping, MaybeStyleSheet,
+ % MaybeDTD, DTDResult, !IO).
+ % Same as write_xml_doc/7 except write the XML doc to the given
% output stream.
%
-:- pred write_xml_doc_cc(io.output_stream::in, T::in, maybe_stylesheet::in,
+:- pred write_xml_doc_cc(io.output_stream::in, T::in,
+ element_mapping::in(element_mapping), maybe_stylesheet::in,
maybe_dtd::in, dtd_generation_result::out, io::di, io::uo) is cc_multi.
- % True if the given type doesn not have multiple top level functors.
- %
-:- pred ok_to_generate_dtd(type_desc::in) is semidet.
-
- % write_dtd(Term, DTDResult, !IO).
- % Write a DTD for the given term to the current output stream. If the
- % type of Term has more than one top level functor then
- % multiple_functors_for_root will be returned in DTDResult and
- % nothing will be written, otherwise ok is returned in DTDResult.
+ % check_ok_to_generate_dtd(ElementMapping, Type, Result).
+ % Check if a DTD can be generated for the given Type using the
+ % functor-to-element mapping scheme ElementMapping. Result will be
+ % `ok' if it is possible to generate a DTD and will be another value
+ % otherwise. See the documentation of the dtd_generation_result type
+ % for the meaning of Result when it is not `ok'.
+ %
+:- pred check_ok_to_generate_dtd(element_mapping::in(element_mapping),
+ type_desc::in, dtd_generation_result::out) is det.
+
+ % write_dtd(Term, ElementMapping, DTDResult, !IO).
+ % Write a DTD for the given term to the current output stream using
+ % ElementMapping to map functors to elements. If a DTD
+ % cannot be generated for Term using ElementMapping then a value
+ % other than `ok' is returned in DTDResult and nothing is written.
+ % See the documentation of the dtd_generation_result type for the
+ % meaning of Result when it is not `ok'.
%
-:- pred write_dtd(T::unused, dtd_generation_result::out, io::di, io::uo)
- is det.
+:- pred write_dtd(T::unused, element_mapping::in(element_mapping),
+ dtd_generation_result::out, io::di, io::uo) is det.
- % write_dtd(Stream, Term, DTDResult, !IO).
- % Write a DTD for the given term to the specified output stream. If the
- % type of Term has more than one top level functor then
- % multiple_functors_for_root will be returned in DTDResult and
- % nothing will be written, otherwise ok is returned in DTDResult.
+ % write_dtd(Stream, Term, ElementMapping, DTDResult, !IO).
+ % Same as write_dtd/5 except the DTD will be written to the given
+ % output stream.
%
-:- pred write_dtd(io.output_stream::in, T::unused, dtd_generation_result::out,
+:- pred write_dtd(io.output_stream::in, T::unused,
+ element_mapping::in(element_mapping), dtd_generation_result::out,
io::di, io::uo) is det.
- % write_dtd_for_type(Type, DTDResult, !IO).
- % Write a DTD for the given type to the current output stream. If the
- % type has more than one top level functor then
- % multiple_functors_for_root will be returned in DTDResult and nothing
- % will be written, otherwise ok is returned in DTDResult.
+ % write_dtd_for_type(Type, ElementMapping, DTDResult, !IO).
+ % Write a DTD for the given type to the current output stream. If a DTD
+ % cannot be generated for Type using ElementMapping then a value
+ % other than `ok' is returned in DTDResult and nothing is written.
+ % See the documentation of the dtd_generation_result type for the
+ % meaning of Result when it is not `ok'.
%
-:- pred write_dtd_from_type(type_desc::in, dtd_generation_result::out,
+:- pred write_dtd_from_type(type_desc::in,
+ element_mapping::in(element_mapping), dtd_generation_result::out,
io::di, io::uo) is det.
- % write_dtd_for_type(Stream, Type, DTDResult, !IO).
- % Write a DTD for the given type to the given output stream. If the
- % type has more than one top level functor then
- % multiple_functors_for_root will be returned in DTDResult and nothing
- % will be written, otherwise ok is returned in DTDResult.
+ % write_dtd_for_type(Stream, Type, ElementMapping, DTDResult, !IO).
+ % Same as write_dtd_for_type/5 except the DTD will be written to the
+ % given output stream.
%
:- pred write_dtd_from_type(io.output_stream::in, type_desc::in,
+ element_mapping::in(element_mapping),
dtd_generation_result::out, io::di, io::uo) is det.
- % write_xml_element(NonCanon, IndentLevel, Term, !IO).
+ % write_xml_element(NonCanon, MakeElement, IndentLevel, Term, !IO).
% Write XML elements for the given term and all its descendents,
% using IndentLevel as the initial indentation level (each
- % indentation level is one space character). No <?xml ... ?>
+ % indentation level is one tab character) and using the MakeElement
+ % predicate to map functors to elements. No <?xml ... ?>
% header will be written. Non-canonical terms will be handled
% according to the value of NonCanon. See the deconstruct
% module in the standard library for more information on this argument.
%
-:- pred write_xml_element(deconstruct.noncanon_handling, int, T, io, io).
-:- mode write_xml_element(in(do_not_allow), in, in, di, uo) is det.
-:- mode write_xml_element(in(canonicalize), in, in, di, uo) is det.
-:- mode write_xml_element(in(include_details_cc), in, in, di, uo) is cc_multi.
-:- mode write_xml_element(in, in, in, di, uo) is cc_multi.
+:- pred write_xml_element(deconstruct.noncanon_handling,
+ element_pred, int, T, io, io).
+:- mode write_xml_element(in(do_not_allow), in(element_pred), in, in, di, uo)
+ is det.
+:- mode write_xml_element(in(canonicalize), in(element_pred), in, in, di, uo)
+ is det.
+:- mode write_xml_element(in(include_details_cc), in(element_pred), in, in,
+ di, uo) is cc_multi.
+:- mode write_xml_element(in, in(element_pred), in, in, di, uo) is cc_multi.
+
+ % Deterministic procedures with the following signature can be used as
+ % custom functor to element mappings. The inputs to the procedure are
+ % a type and some information about the required functor for that type
+ % if the type is a discriminated union. The output should be a well
+ % formed XML element name and a list of attributes that should be set
+ % for that element. See the types `maybe_functor_info' and
+ % `attribute' below.
+ %
+:- type element_pred == (pred(type_desc, maybe_functor_info, string,
+ list(attribute))).
+
+:- inst element_pred == (pred(in, in, out, out) is det).
+
+ % Values of this type are passed to custom functor-to-element
+ % mapping predicates to tell the predicate which functor to generate
+ % an element name for if the type is a discriminated union. If the
+ % type is not a discriminated union, then not_a_du is passed to
+ % the predicate when requesting an element for the type.
+ %
+:- type maybe_functor_info
+ % The functor's name and arity.
+ ---> du_functor(
+ functor_name :: string,
+ functor_arity :: int
+ )
+ % The type is not a discriminated union.
+ ; not_a_du.
+
+ % Values of this type specify attributes that should be set by
+ % particular element. The attribute_name field specifys the name
+ % of the attribute in the generated XML and the attribute_source
+ % field indicates where the attributes value should come from.
+ %
+:- type attribute
+ ---> attribute(
+ attribute_name :: string,
+ attribute_source :: attribute_source
+ ).
+
+ % Possible attribute sources.
+ %
+:- type attribute_source
+ % The original functor name as returned by
+ % deconstruct.deconstruct/5.
+ ---> functor
+ % The field name if the functor appears in a
+ % named field (If the field is not named then this
+ % attribute is omitted.
+ ; field_name
+ % The fully qualified type name the functor is for.
+ ; type_name
+ % The arity of the functor as returned by
+ % deconstruct.deconstruct/5.
+ ; arity.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module string, list, char, bool, array.
-:- import_module exception, map.
+:- import_module string, char, bool, array.
+:- import_module exception, map, require.
%-----------------------------------------------------------------------------%
-write_xml_doc(X, MaybeStyleSheet, MaybeDTD, DTDResult, !IO) :-
+write_xml_doc(X, ElementMapping, MaybeStyleSheet, MaybeDTD, DTDResult, !IO) :-
+ check_ok_to_generate_dtd(MaybeDTD, ElementMapping, type_of(X),
+ DTDResult),
(
- ( MaybeDTD \= embed ; ok_to_generate_dtd(type_of(X)) )
+ DTDResult = ok
->
- DTDResult = ok,
+ get_element_pred(ElementMapping, MakeElement),
write_xml_header(no, !IO),
write_stylesheet_ref(MaybeStyleSheet, !IO),
- write_doctype(canonicalize, X, MaybeDTD, _, !IO),
- write_xml_element(canonicalize, 0, X, !IO)
+ write_doctype(canonicalize, X, ElementMapping, MaybeDTD, _,
+ !IO),
+ write_xml_element(canonicalize, MakeElement, 0, X, !IO)
;
- DTDResult = multiple_functors_for_root
+ true
).
-write_xml_doc(Stream, X, MaybeStyleSheet, MaybeDTD, DTDResult, !IO) :-
+write_xml_doc(Stream, X, ElementMapping, MaybeStyleSheet, MaybeDTD,
+ DTDResult, !IO) :-
io.set_output_stream(Stream, OrigStream, !IO),
- write_xml_doc(X, MaybeStyleSheet, MaybeDTD, DTDResult, !IO),
+ write_xml_doc(X, ElementMapping, MaybeStyleSheet, MaybeDTD, DTDResult,
+ !IO),
io.set_output_stream(OrigStream, _, !IO).
-write_xml_doc_cc(X, MaybeStyleSheet, MaybeDTD, DTDResult, !IO) :-
+write_xml_doc_cc(X, ElementMapping, MaybeStyleSheet, MaybeDTD, DTDResult,
+ !IO) :-
+ check_ok_to_generate_dtd(MaybeDTD, ElementMapping, type_of(X),
+ DTDResult),
(
- ( MaybeDTD = embed ; ok_to_generate_dtd(type_of(X)) )
+ DTDResult = ok
->
- DTDResult = ok,
+ get_element_pred(ElementMapping, MakeElement),
write_xml_header(no, !IO),
write_stylesheet_ref(MaybeStyleSheet, !IO),
- write_doctype(include_details_cc, X, MaybeDTD, _, !IO),
- write_xml_element(include_details_cc, 0, X, !IO)
+ write_doctype(include_details_cc, X, ElementMapping, MaybeDTD,
+ _, !IO),
+ write_xml_element(include_details_cc, MakeElement, 0, X, !IO)
;
- DTDResult = multiple_functors_for_root
+ true
).
-write_xml_doc_cc(Stream, X, MaybeStyleSheet, MaybeDTD, DTDResult, !IO) :-
+write_xml_doc_cc(Stream, X, ElementMapping, MaybeStyleSheet, MaybeDTD,
+ DTDResult, !IO) :-
io.set_output_stream(Stream, OrigStream, !IO),
- write_xml_doc_cc(X, MaybeStyleSheet, MaybeDTD, DTDResult, !IO),
+ write_xml_doc_cc(X, ElementMapping, MaybeStyleSheet, MaybeDTD,
+ DTDResult, !IO),
io.set_output_stream(OrigStream, _, !IO).
-write_xml_element(NonCanon, IndentLevel, X, !IO) :-
+write_xml_element(NonCanon, MakeElement, IndentLevel, X, !IO) :-
type_to_univ(X, Univ),
- write_xml_element_univ(NonCanon, IndentLevel, Univ, [], _, !IO).
+ write_xml_element_univ(NonCanon, MakeElement, IndentLevel, Univ, [], _,
+ !IO).
-write_dtd(Term, DTDResult, !IO) :-
+write_dtd(Term, ElementMapping, DTDResult, !IO) :-
type_of(Term) = TypeDesc,
- write_dtd_from_type(TypeDesc, DTDResult, !IO).
+ write_dtd_from_type(TypeDesc, ElementMapping, DTDResult, !IO).
-write_dtd(Stream, Term, DTDResult, !IO) :-
+write_dtd(Stream, Term, ElementMapping, DTDResult, !IO) :-
io.set_output_stream(Stream, OrigStream, !IO),
- write_dtd(Term, DTDResult, !IO),
+ write_dtd(Term, ElementMapping, DTDResult, !IO),
io.set_output_stream(OrigStream, _, !IO).
-write_dtd_from_type(Stream, TypeDesc, DTDResult, !IO) :-
+write_dtd_from_type(Stream, TypeDesc, ElementMapping, DTDResult, !IO) :-
io.set_output_stream(Stream, OrigStream, !IO),
- write_dtd_from_type(TypeDesc, DTDResult, !IO),
+ write_dtd_from_type(TypeDesc, ElementMapping, DTDResult, !IO),
io.set_output_stream(OrigStream, _, !IO).
:- pred write_xml_header(maybe(string)::in, io::di, io::uo) is det.
@@ -277,20 +451,32 @@
io.write_string(Href, !IO),
io.write_string("""?>\n", !IO).
-:- pred write_doctype(deconstruct.noncanon_handling, T, maybe_dtd,
- dtd_generation_result, io, io).
-:- mode write_doctype(in(canonicalize), in, in, out, di, uo) is det.
-:- mode write_doctype(in(do_not_allow), in, in, out, di, uo) is det.
-:- mode write_doctype(in(include_details_cc), in, in, out, di, uo) is cc_multi.
-:- mode write_doctype(in, in, in, out, di, uo) is cc_multi.
-
-write_doctype(_, _, no_dtd, ok, !IO).
-write_doctype(_, T, embed, DTDResult, !IO) :-
- write_dtd(T, DTDResult, !IO),
+:- pred write_doctype(deconstruct.noncanon_handling, T, element_mapping,
+ maybe_dtd, dtd_generation_result, io, io).
+:- mode write_doctype(in(canonicalize), in, in(element_mapping), in, out,
+ di, uo) is det.
+:- mode write_doctype(in(do_not_allow), in, in(element_mapping), in, out,
+ di, uo) is det.
+:- mode write_doctype(in(include_details_cc), in, in(element_mapping), in, out,
+ di, uo) is cc_multi.
+:- mode write_doctype(in, in, in(element_mapping), in, out,
+ di, uo) is cc_multi.
+
+write_doctype(_, _, _, no_dtd, ok, !IO).
+write_doctype(_, T, ElementMapping, embed, DTDResult, !IO) :-
+ write_dtd(T, ElementMapping, DTDResult, !IO),
io.nl(!IO).
-write_doctype(NonCanon, T, external(DocType), ok, !IO) :-
- deconstruct.deconstruct(T, NonCanon, Functor, _, _),
- Root = get_element(type_of(T), from_functor_name(Functor)),
+write_doctype(NonCanon, T, ElementMapping, external(DocType), ok, !IO) :-
+ get_element_pred(ElementMapping, MakeElement),
+ deconstruct.deconstruct(T, NonCanon, Functor, Arity, _),
+ (
+ is_discriminated_union(type_of(T), _)
+ ->
+ Request = du_functor(Functor, Arity)
+ ;
+ Request = not_a_du
+ ),
+ MakeElement(type_of(T), Request, Root, _),
io.write_string("<!DOCTYPE ", !IO),
io.write_string(Root, !IO),
(
@@ -310,10 +496,98 @@
),
io.write_string(""">\n", !IO).
+ % Implementation of the `unique' predefined mapping scheme.
+ %
+:- pred make_unique_element(type_desc::in, maybe_functor_info::in,
+ string::out, list(attribute)::out) is det.
+
+% XXX This should be uncommented once memoing can be switched off for grades
+% which don't support it.
+% :- pragma memo(make_unique_element/4).
+
+make_unique_element(TypeDesc, du_functor(Functor, Arity), Element,
+ all_attributes) :-
+ (
+ common_mercury_functor(Functor, ReservedElement)
+ ->
+ MangledElement = ReservedElement
+ ;
+ MangledElement = mangle(Functor)
+ ),
+ Element = MangledElement ++ "--" ++ string.int_to_string(Arity) ++
+ "--" ++ mangle(type_name(TypeDesc)).
+make_unique_element(TypeDesc, not_a_du, Element, Attributes) :-
+ (
+ is_primitive_type(TypeDesc, PrimitiveElement)
+ ->
+ Element = PrimitiveElement,
+ Attributes = [attribute("type", type_name),
+ attribute("field", field_name)]
+ ;
+ is_array(TypeDesc, _)
+ ->
+ Element = array_element ++ "--" ++ mangle(type_name(TypeDesc)),
+ Attributes = all_attributes
+ ;
+ Element = mangle(type_name(TypeDesc)),
+ Attributes = all_attributes
+ ).
+
+ % Implementation of the `simple' mapping scheme.
+ %
+:- pred make_simple_element(type_desc::in, maybe_functor_info::in,
+ string::out, list(attribute)::out) is det.
+
+% XXX This should be uncommented once memoing can be switched off for grades
+% which don't support it.
+% :- pragma memo(make_simple_element/4).
+
+make_simple_element(_, du_functor(Functor, _), Element, all_attributes) :-
+ (
+ common_mercury_functor(Functor, ReservedElement)
+ ->
+ Element = ReservedElement
+ ;
+ Element = mangle(Functor)
+ ).
+make_simple_element(TypeDesc, not_a_du, Element, Attributes) :-
+ (
+ is_primitive_type(TypeDesc, PrimitiveElement)
+ ->
+ Element = PrimitiveElement,
+ Attributes = [attribute("type", type_name),
+ attribute("field", field_name)]
+ ;
+ is_array(TypeDesc, _)
+ ->
+ Element = array_element,
+ Attributes = all_attributes
+ ;
+ Element = "Unknown",
+ Attributes = all_attributes
+ ).
+
+:- func all_attributes = list(attribute).
+
+all_attributes = [
+ attribute("functor", functor),
+ attribute("field", field_name),
+ attribute("type", type_name),
+ attribute("arity", arity)
+ ].
+
+:- pred get_element_pred(element_mapping::in(element_mapping),
+ element_pred::out(element_pred)) is det.
+
+get_element_pred(simple, make_simple_element).
+get_element_pred(unique, make_unique_element).
+get_element_pred(custom(P), P).
+
%-----------------------------------------------------------------------------%
%
-% Some reserved element names. Reserved element names all start with a
-% capital letter so as not to conflict with a mangled element name.
+% Some reserved element names for the predefined mapping schemes. Reserved
+% element names all start with a capital letter so as not to conflict with a
+% mangled element name.
%
% A prefix for functors that start with a capital letter or
@@ -334,13 +608,6 @@
common_mercury_functor("[]", "Nil").
common_mercury_functor("{}", "Tuple").
- % A general element for types whose structure we do not generate
- % DTD rules for.
- %
-:- func unrecognized_element = string.
-
-unrecognized_element = "Unrecognized".
-
:- func array_element = string.
array_element = "Array".
@@ -417,101 +684,66 @@
%-----------------------------------------------------------------------------%
-:- type element_request
- ---> from_functor_name(string)
- ; from_functor_num(int).
+ % Return a list of elements, functors and arities
+ % (if the type is a discriminated union), argument types and
+ % attributes for all the functors for the type. Only one element
+ % will be in each list if the type is not a discriminated union.
+ %
+:- pred get_elements_and_args(element_pred::in(element_pred),
+ type_desc::in, list(string)::out, list(maybe(string))::out,
+ list(maybe(int))::out, list(list(type_desc))::out,
+ list(list(attribute))::out) is det.
% XXX This should be uncommented once memoing can be switched off for grades
% which don't support it.
-% :- pragma memo(get_element/2).
-
- % Return an element for a functor for the type.
- %
-:- func get_element(type_desc, element_request) = string.
-
-get_element(TypeDesc, ElementRequest) = Element :-
- (
- (
- ElementRequest = from_functor_num(FunctorNum),
- get_functor(TypeDesc, FunctorNum, Functor, _, _)
- ;
- ElementRequest = from_functor_name(Functor),
- is_discriminated_union(TypeDesc, _)
- )
- ->
- (
- common_mercury_functor(Functor, ReservedElement)
- ->
- MangledElement = ReservedElement
- ;
- MangledElement = mangle(Functor)
- ),
- MangledType = "--" ++ mangle(type_name(TypeDesc))
- ;
- is_primitive_type(TypeDesc, PrimitiveElement)
- ->
- % primitive element names are reserved, so no mangling is
- % required.
- MangledElement = PrimitiveElement,
- MangledType = ""
- ;
- is_array(TypeDesc, _)
- ->
- % array element name is also reserved.
- MangledElement = array_element,
- MangledType = "--" ++ mangle(type_name(TypeDesc))
- ;
- MangledElement = unrecognized_element,
- MangledType = ""
- ),
- Element = MangledElement ++ MangledType.
-
- % Return a list of elements and argument types for all the
- % functors in a discriminated union or a list with just one
- % element for the type if it's not a du.
- %
-:- pred get_elements_and_args(type_desc::in, list(string)::out,
- list(string)::out, list(list(type_desc))::out) is det.
+% :- pragma memo(get_elements_and_args/7).
-get_elements_and_args(TypeDesc, Elements, Functors, MaybeArgTypeLists) :-
- NumFunctors = num_functors(TypeDesc),
+get_elements_and_args(MakeElement, TypeDesc, Elements, MaybeFunctors,
+ MaybeArities, ArgTypeLists, AttributeLists) :-
(
- NumFunctors > 0
+ is_discriminated_union(TypeDesc, NumFunctors)
->
FunctorNums = 0 `..` (NumFunctors - 1),
- Elements = list.map(func(X) = get_element(TypeDesc,
- from_functor_num(X)), FunctorNums),
(
list.map3(get_functor(TypeDesc), FunctorNums,
- Functors0, _, MaybeArgTypeLists0)
+ Functors, Arities, ArgTypeLists0)
->
- Functors = Functors0,
- MaybeArgTypeLists = MaybeArgTypeLists0
+ list.map(yessify, Functors, MaybeFunctors),
+ list.map(yessify, Arities, MaybeArities),
+ ArgTypeLists = ArgTypeLists0,
+ Requests = list.map_corresponding(make_du_functor,
+ Functors, Arities),
+ P = (pred(A::in, B::out, C::out) is det :-
+ MakeElement(TypeDesc, A, B, C)),
+ list.map2(P, Requests, Elements, AttributeLists)
;
- throw(term_to_xml_internal_error("get_elements_and_args",
+ throw(software_error(
+ "term_to_xml.get_elements_and_args: " ++
"get_functor failed for discriminated union"))
)
;
- Elements = [get_element(TypeDesc, from_functor_num(0))],
+ MakeElement(TypeDesc, not_a_du, Element, Attributes),
+ Elements = [Element],
+ AttributeLists = [Attributes],
+ MaybeFunctors = [no],
+ MaybeArities = [no],
(
is_array(TypeDesc, ArgType)
->
- MaybeArgTypeLists = [[ArgType]],
- array.from_list([1], Array),
- % We want the same functor name returned by
- % deconstruct so it matches the "functor" field in
- % the `Array--*' element.
- deconstruct.deconstruct(Array, canonicalize, Functor,
- _, _),
- Functors = [Functor]
+ ArgTypeLists = [[ArgType]]
;
- MaybeArgTypeLists = [[]],
- % We make these the same so the "functor" attribute
- % isn't fixed.
- Functors = Elements
+ ArgTypeLists = [[]]
)
).
+:- pred yessify(T::in, maybe(T)::out) is det.
+
+yessify(X, yes(X)).
+
+:- func make_du_functor(string, int) = maybe_functor_info.
+
+make_du_functor(Functor, Arity) = du_functor(Functor, Arity).
+
:- pred primitive_value(univ::in, string::out) is semidet.
primitive_value(Univ, PrimValue) :-
@@ -535,22 +767,23 @@
%-----------------------------------------------------------------------------%
:- pred write_xml_element_univ(deconstruct.noncanon_handling,
- int, univ, list(maybe(string)), list(maybe(string)), io, io).
-:- mode write_xml_element_univ(in(do_not_allow), in, in, in, out, di, uo)
- is det.
-:- mode write_xml_element_univ(in(canonicalize), in, in, in, out, di, uo)
- is det.
-:- mode write_xml_element_univ(in(include_details_cc), in, in, in, out,
- di, uo) is cc_multi.
-:- mode write_xml_element_univ(in, in, in, in, out, di, uo) is cc_multi.
+ element_pred, int, univ, list(maybe(string)),
+ list(maybe(string)), io, io).
+:- mode write_xml_element_univ(in(do_not_allow), in(element_pred), in, in,
+ in, out, di, uo) is det.
+:- mode write_xml_element_univ(in(canonicalize), in(element_pred), in, in,
+ in, out, di, uo) is det.
+:- mode write_xml_element_univ(in(include_details_cc), in(element_pred), in,
+ in, in, out, di, uo) is cc_multi.
+:- mode write_xml_element_univ(in, in(element_pred), in, in, in, out, di, uo)
+ is cc_multi.
% Write an element and all it's descendents to the current output
- % stream.
- % If MaybeFields isn't empty then its head is used for the "field"
- % attribute and the Tail is returned in RemainingMaybeFieldNames.
- % This is so it can be called using foldl2.
+ % stream. If MaybeFields isn't empty then its head is used for the
+ % `field' attribute and the Tail is returned in
+ % RemainingMaybeFieldNames. This is so it can be called using foldl2.
%
-write_xml_element_univ(NonCanon, IndentLevel, Univ,
+write_xml_element_univ(NonCanon, MakeElement, IndentLevel, Univ,
MaybeFieldNames, RemainingMaybeFieldNames, !IO) :-
(
MaybeFieldNames = [MaybeFieldName | RemainingMaybeFieldNames]
@@ -562,27 +795,42 @@
deconstruct.deconstruct(Term, NonCanon, Functor, Arity, Args),
Term = univ_value(Univ),
TypeDesc = type_of(Term),
- Element = get_element(TypeDesc, from_functor_name(Functor)),
+ (
+ is_discriminated_union(TypeDesc, _)
+ ->
+ Request = du_functor(Functor, Arity)
+ ;
+ Request = not_a_du
+ ),
+ MakeElement(TypeDesc, Request, Element, Attributes),
(
primitive_value(Univ, PrimValue)
->
indent(IndentLevel, !IO),
- write_primitive_element(Element, PrimValue, MaybeFieldName,
- !IO)
+ write_primitive_element(Element, Attributes, PrimValue,
+ MaybeFieldName, TypeDesc, !IO)
;
(
Args = [],
indent(IndentLevel, !IO),
- write_empty_element(Element, Functor, MaybeFieldName,
- TypeDesc, !IO)
+ write_empty_element(Element, Attributes, yes(Functor),
+ yes(Arity), MaybeFieldName, TypeDesc, !IO)
;
Args = [_ | _],
- ChildMaybeFieldNames = get_field_names(TypeDesc,
- Functor, Arity),
+ % XXX This has been commented out until a bug in
+ % the runtime system has been fixed that causes
+ % a seg fault when construct.get_functor is invoked on
+ % a functor with existentially quantified argument
+ % types.
+ % ChildMaybeFieldNames = get_field_names(TypeDesc,
+ % Functor, Arity),
+ ChildMaybeFieldNames = [],
indent(IndentLevel, !IO),
- write_element_start(Element, Functor, MaybeFieldName,
+ write_element_start(Element, Attributes, yes(Functor),
+ yes(Arity), MaybeFieldName,
TypeDesc, !IO),
- write_child_xml_elements(NonCanon, IndentLevel + 1,
+ write_child_xml_elements(NonCanon, MakeElement,
+ IndentLevel + 1,
Args, ChildMaybeFieldNames, !IO),
indent(IndentLevel, !IO),
write_element_end(Element, !IO)
@@ -603,16 +851,15 @@
type_ctor_name(TypeCtor) = "array",
type_ctor_module_name(TypeCtor) = "array".
+:- func get_field_names(type_desc, string, int) = list(maybe(string)).
+
% XXX This should be uncommented once memoing can be switched off for grades
% which don't support it.
% :- pragma memo(get_field_names/3).
-:- func get_field_names(type_desc, string, int) = list(maybe(string)).
-
get_field_names(TypeDesc, Functor, Arity) = MaybeFields :-
- NumFunctors = num_functors(TypeDesc),
(
- NumFunctors > 0
+ is_discriminated_union(TypeDesc, NumFunctors)
->
FunctorNums = 0`..`(NumFunctors - 1),
(
@@ -650,62 +897,64 @@
%
:- pred write_child_xml_elements(deconstruct.noncanon_handling,
- int, list(univ), list(maybe(string)), io, io).
-:- mode write_child_xml_elements(in(do_not_allow), in, in, in, di, uo)
- is det.
-:- mode write_child_xml_elements(in(canonicalize), in, in, in, di, uo)
- is det.
-:- mode write_child_xml_elements(in(include_details_cc), in, in, in,
- di, uo) is cc_multi.
-:- mode write_child_xml_elements(in, in, in, in, di, uo) is cc_multi.
+ element_pred, int, list(univ), list(maybe(string)), io, io).
+:- mode write_child_xml_elements(in(do_not_allow), in(element_pred), in, in,
+ in, di, uo) is det.
+:- mode write_child_xml_elements(in(canonicalize), in(element_pred), in, in,
+ in, di, uo) is det.
+:- mode write_child_xml_elements(in(include_details_cc), in(element_pred),
+ in, in, in, di, uo) is cc_multi.
+:- mode write_child_xml_elements(in, in(element_pred), in, in, in, di, uo)
+ is cc_multi.
-write_child_xml_elements(NonCanon, IndentLevel, Args,
+write_child_xml_elements(NonCanon, MakeElement, IndentLevel, Args,
MaybeFieldNames, !IO) :-
(
NonCanon = do_not_allow,
list.foldl2(
write_xml_element_univ_do_not_allow(
- IndentLevel), Args,
+ MakeElement, IndentLevel), Args,
MaybeFieldNames, _, !IO)
;
NonCanon = canonicalize,
list.foldl2(
write_xml_element_univ_canonicalize(
- IndentLevel), Args,
+ MakeElement, IndentLevel), Args,
MaybeFieldNames, _, !IO)
;
NonCanon = include_details_cc,
list.foldl2(
write_xml_element_univ_include_details_cc(
- IndentLevel), Args,
+ MakeElement, IndentLevel), Args,
MaybeFieldNames, _, !IO)
).
-:- pred write_xml_element_univ_do_not_allow(int::in, univ::in,
- list(maybe(string))::in, list(maybe(string))::out, io::di, io::uo)
- is det.
+:- pred write_xml_element_univ_do_not_allow(element_pred::in(element_pred),
+ int::in, univ::in, list(maybe(string))::in, list(maybe(string))::out,
+ io::di, io::uo) is det.
-write_xml_element_univ_do_not_allow(IndentLevel, Univ,
+write_xml_element_univ_do_not_allow(MakeElement, IndentLevel, Univ,
MaybeFieldNames0, MaybeFieldNames, !IO) :-
- write_xml_element_univ(do_not_allow, IndentLevel,
+ write_xml_element_univ(do_not_allow, MakeElement, IndentLevel,
Univ, MaybeFieldNames0, MaybeFieldNames, !IO).
-:- pred write_xml_element_univ_canonicalize(int::in, univ::in,
- list(maybe(string))::in, list(maybe(string))::out, io::di, io::uo)
- is det.
+:- pred write_xml_element_univ_canonicalize(element_pred::in(element_pred),
+ int::in, univ::in, list(maybe(string))::in, list(maybe(string))::out,
+ io::di, io::uo) is det.
-write_xml_element_univ_canonicalize(IndentLevel, Univ,
+write_xml_element_univ_canonicalize(MakeElement, IndentLevel, Univ,
MaybeFieldNames0, MaybeFieldNames, !IO) :-
- write_xml_element_univ(canonicalize, IndentLevel,
+ write_xml_element_univ(canonicalize, MakeElement, IndentLevel,
Univ, MaybeFieldNames0, MaybeFieldNames, !IO).
-:- pred write_xml_element_univ_include_details_cc(int::in, univ::in,
+:- pred write_xml_element_univ_include_details_cc(
+ element_pred::in(element_pred), int::in, univ::in,
list(maybe(string))::in, list(maybe(string))::out, io::di, io::uo)
is cc_multi.
-write_xml_element_univ_include_details_cc(IndentLevel, Univ,
+write_xml_element_univ_include_details_cc(MakeElement, IndentLevel, Univ,
MaybeFieldNames0, MaybeFieldNames, !IO) :-
- write_xml_element_univ(include_details_cc,
+ write_xml_element_univ(include_details_cc, MakeElement,
IndentLevel, Univ, MaybeFieldNames0, MaybeFieldNames, !IO).
%-----------------------------------------------------------------------------%
@@ -725,85 +974,104 @@
true
).
-:- pred write_primitive_element(string::in, string::in,
- maybe(string)::in, io::di, io::uo) is det.
+:- pred write_primitive_element(string::in, list(attribute)::in, string::in,
+ maybe(string)::in, type_desc::in, io::di, io::uo) is det.
-write_primitive_element(Element, Value, MaybeFieldName, !IO) :-
+write_primitive_element(Element, Attributes, Value, MaybeFieldName,
+ TypeDesc, !IO) :-
io.write_string("<", !IO),
io.write_string(Element, !IO),
- write_field_name_attribute(MaybeFieldName, !IO),
+ list.foldl(write_attribute(no, no, TypeDesc, MaybeFieldName),
+ Attributes, !IO),
io.write_string(">", !IO),
write_xml_escaped_string(Value, !IO),
io.write_string("</", !IO),
io.write_string(Element, !IO),
io.write_string(">\n", !IO).
-:- pred write_xml_escaped_string(string::in, io::di, io::uo) is det.
-
-write_xml_escaped_string(Str, !IO) :-
- string.foldl(write_xml_escaped_char, Str, !IO).
-
-:- pred write_xml_escaped_char(char::in, io::di, io::uo) is det.
-
-write_xml_escaped_char(Chr, !IO) :-
- (
- xml_predefined_entity(Chr, Str)
- ->
- io.write_string(Str, !IO)
- ;
- io.write_char(Chr, !IO)
- ).
-
-:- pred write_element_start(string::in, string::in,
- maybe(string)::in, type_desc::in, io::di, io::uo) is det.
+:- pred write_element_start(string::in, list(attribute)::in, maybe(string)::in,
+ maybe(int)::in, maybe(string)::in, type_desc::in, io::di, io::uo) is
+ det.
-write_element_start(Element, Functor, MaybeField, TypeDesc, !IO) :-
+write_element_start(Element, Attributes, MaybeFunctor, MaybeArity, MaybeField,
+ TypeDesc, !IO) :-
io.write_string("<", !IO),
io.write_string(Element, !IO),
- write_functor_attribute(Functor, !IO),
- write_field_name_attribute(MaybeField, !IO),
- write_type_name_attribute(TypeDesc, !IO),
+ list.foldl(write_attribute(MaybeFunctor, MaybeArity, TypeDesc,
+ MaybeField), Attributes, !IO),
io.write_string(">\n", !IO).
-:- pred write_empty_element(string::in, string::in, maybe(string)::in,
- type_desc::in, io::di, io::uo) is det.
+:- pred write_empty_element(string::in, list(attribute)::in,
+ maybe(string)::in, maybe(int)::in, maybe(string)::in, type_desc::in,
+ io::di, io::uo) is det.
-write_empty_element(Element, Functor, MaybeField, TypeDesc, !IO) :-
+write_empty_element(Element, Attributes, MaybeFunctor, MaybeArity, MaybeField,
+ TypeDesc, !IO) :-
io.write_string("<", !IO),
io.write_string(Element, !IO),
- write_functor_attribute(Functor, !IO),
- write_field_name_attribute(MaybeField, !IO),
- write_type_name_attribute(TypeDesc, !IO),
+ list.foldl(write_attribute(MaybeFunctor, MaybeArity, TypeDesc,
+ MaybeField), Attributes, !IO),
io.write_string(" />\n", !IO).
-:- pred write_field_name_attribute(maybe(string)::in, io::di, io::uo) is det.
+:- pred write_element_end(string::in, io::di, io::uo) is det.
-write_field_name_attribute(no, !IO).
-write_field_name_attribute(yes(Field), !IO) :-
- io.write_string(" field=""", !IO),
- write_xml_escaped_string(Field, !IO),
- io.write_string("""", !IO).
+write_element_end(Element, !IO) :-
+ io.write_string("</", !IO),
+ io.write_string(Element, !IO),
+ io.write_string(">\n", !IO).
-:- pred write_type_name_attribute(type_desc::in, io::di, io::uo) is det.
+:- pred write_attribute(maybe(string)::in, maybe(int)::in,
+ type_desc::in, maybe(string)::in, attribute::in, io::di, io::uo)
+ is det.
-write_type_name_attribute(TypeDesc, !IO) :-
- io.write_string(" typename=""", !IO),
- write_xml_escaped_string(type_name(TypeDesc), !IO),
- io.write_string("""", !IO).
+write_attribute(MaybeFunctor, MaybeArity, TypeDesc, MaybeFieldName,
+ attribute(Name, Source), !IO) :-
+ (
+ Source = functor,
+ MaybeValue = MaybeFunctor
+ ;
+ Source = arity,
+ (
+ MaybeArity = yes(Arity),
+ MaybeValue = yes(string.int_to_string(Arity))
+ ;
+ MaybeArity = no,
+ MaybeValue = no
+ )
+ ;
+ Source = type_name,
+ MaybeValue = yes(type_name(TypeDesc))
+ ;
+ Source = field_name,
+ MaybeValue = MaybeFieldName
+ ),
+ (
+ MaybeValue = yes(Value)
+ ->
+ io.write_string(" ", !IO),
+ io.write_string(Name, !IO),
+ io.write_string("=""", !IO),
+ write_xml_escaped_string(Value, !IO),
+ io.write_string("""", !IO)
+ ;
+ true
+ ).
-:- pred write_functor_attribute(string::in, io::di, io::uo) is det.
+:- pred write_xml_escaped_string(string::in, io::di, io::uo) is det.
-write_functor_attribute(Functor, !IO) :-
- io.write_string(" functor=""", !IO),
- write_xml_escaped_string(Functor, !IO),
- io.write_string("""", !IO).
+write_xml_escaped_string(Str, !IO) :-
+ string.foldl(write_xml_escaped_char, Str, !IO).
-:- pred write_element_end(string::in, io::di, io::uo) is det.
+:- pred write_xml_escaped_char(char::in, io::di, io::uo) is det.
-write_element_end(Element, !IO) :-
- io.write_string("</", !IO),
- io.write_string(Element, !IO),
- io.write_string(">\n", !IO).
+write_xml_escaped_char(Chr, !IO) :-
+ (
+ xml_predefined_entity(Chr, Str)
+ ->
+ io.write_string(Str, !IO)
+ ;
+ io.write_char(Chr, !IO)
+ ).
:- pred xml_predefined_entity(char::in, string::out) is semidet.
@@ -818,228 +1086,291 @@
% Predicates to write the DTD for a type.
%
-write_dtd_from_type(TypeDesc, DTDResult, !IO) :-
+write_dtd_from_type(TypeDesc, ElementMapping, DTDResult, !IO) :-
+ check_ok_to_generate_dtd(ElementMapping, TypeDesc, DTDResult),
(
- get_elements_and_args(TypeDesc, [RootElement], [_],
- [ArgTypes])
+ DTDResult = ok
->
- io.write_string("<!DOCTYPE ", !IO),
- io.write_string(RootElement, !IO),
- io.write_string(" [\n\n<!-- Builtin Mercury types -->\n\n",
- !IO),
- list.foldl(write_primitive_dtd_element,
- ["String", "Char", "Int", "Float"], !IO),
- io.nl(!IO),
- some [!AlreadyDone] (
- !:AlreadyDone = map.init,
- map.set(!.AlreadyDone, type_of(1), unit,
- !:AlreadyDone),
- map.set(!.AlreadyDone, type_of('c'), unit,
- !:AlreadyDone),
- map.set(!.AlreadyDone, type_of(""), unit,
- !:AlreadyDone),
- map.set(!.AlreadyDone, type_of(1.0), unit,
- !:AlreadyDone),
- AlreadyDone = !.AlreadyDone
- ),
- write_dtd_types([TypeDesc | ArgTypes], AlreadyDone, [],
- Unrecognised, !IO),
+ get_element_pred(ElementMapping, MakeElement),
(
- Unrecognised = []
+ get_elements_and_args(MakeElement, TypeDesc,
+ [RootElement], [_], [_], [ArgTypes], _)
+ ->
+ io.write_string("<!DOCTYPE ", !IO),
+ io.write_string(RootElement, !IO),
+ io.write_string(" [\n\n",
+ !IO),
+ write_dtd_types(MakeElement, [TypeDesc | ArgTypes],
+ map.init, !IO),
+ io.write_string("\n]>", !IO),
+ DTDResult = ok
;
- Unrecognised = [_ | _],
- io.write_string("<!-- The following types have ", !IO),
- io.write_string("been assigned to the ", !IO),
- io.write_string("`Unrecognised' element:\n\t", !IO),
- io.write_list(list.map(type_name, Unrecognised),
- "\n\t", io.write_string, !IO),
- io.write_string("\n-->\n\n", !IO),
- write_unrecognised_dtd_element(!IO)
- ),
- io.write_string("\n]>", !IO),
- DTDResult = ok
+ throw(software_error("term_to_xml.write_dtd_from_type"
+ ++ ": not ok to generate DTD"))
+ )
;
- DTDResult = multiple_functors_for_root
+ true
).
-ok_to_generate_dtd(TypeDesc) :-
- get_elements_and_args(TypeDesc, [_], [_], [_]).
-
-:- pred write_primitive_dtd_element(string::in, io::di, io::uo)
- is det.
+check_ok_to_generate_dtd(ElementMapping, TypeDesc, Result) :-
+ get_element_pred(ElementMapping, MakeElement),
+ (
+ get_elements_and_args(MakeElement, TypeDesc, [_], [_], [_],
+ [_], [_])
+ ->
+ check_types_ok(MakeElement, [TypeDesc],
+ map.init, map.init, Result)
+ ;
+ Result = multiple_functors_for_root
+ ).
-write_primitive_dtd_element(Element, !IO) :-
- io.write_string("<!ELEMENT ", !IO),
- io.write_string(Element, !IO),
- io.write_string(" (#PCDATA)>\n", !IO),
- write_dtd_field_attlist(Element, !IO).
+:- pred check_ok_to_generate_dtd(maybe_dtd::in,
+ element_mapping::in(element_mapping),
+ type_desc::in, dtd_generation_result::out) is det.
+
+check_ok_to_generate_dtd(no_dtd, _, _, ok).
+check_ok_to_generate_dtd(external(_), _, _, ok).
+check_ok_to_generate_dtd(embed, ElementMapping, TypeDesc, Result) :-
+ check_ok_to_generate_dtd(ElementMapping, TypeDesc, Result).
+
+:- pred check_types_ok(element_pred::in(element_pred),
+ list(type_desc)::in, map(type_desc, unit)::in,
+ map(string, type_desc)::in, dtd_generation_result::out) is det.
+
+check_types_ok(_, [], _, _, ok).
+check_types_ok(MakeElement, [TypeDesc | TypeDescs], DoneTypeDescs,
+ ElementsSoFar, Result) :-
+ (
+ (
+ is_discriminated_union(TypeDesc, _)
+ ;
+ is_array(TypeDesc, _)
+ ;
+ is_primitive_type(TypeDesc, _)
+ )
+ ->
+ (
+ map.search(DoneTypeDescs, TypeDesc, _)
+ ->
+ check_types_ok(MakeElement, TypeDescs, DoneTypeDescs,
+ ElementsSoFar, Result)
+ ;
+ get_elements_and_args(MakeElement, TypeDesc, Elements,
+ _, _, ArgLists, _),
+ list.filter(map.contains(ElementsSoFar), Elements,
+ DupElements),
+ (
+ DupElements = [DupElement | _],
+ map.lookup(ElementsSoFar, DupElement,
+ DupTypeDesc),
+ DupTypes = [TypeDesc, DupTypeDesc],
+ Result = duplicate_elements(DupElement,
+ DupTypes)
+ ;
+ DupElements = [],
+ list.merge_and_remove_dups(
+ list.condense(ArgLists),
+ TypeDescs, NewTypeDescs),
+ list.duplicate(length(Elements), TypeDesc,
+ TypeDescList),
+ map.det_insert_from_corresponding_lists(
+ ElementsSoFar, Elements, TypeDescList,
+ NewElementsSoFar),
+ map.det_insert(DoneTypeDescs, TypeDesc, unit,
+ NewDoneTypeDescs),
+ check_types_ok(MakeElement, NewTypeDescs,
+ NewDoneTypeDescs, NewElementsSoFar,
+ Result)
+ )
+ )
+ ;
+ Result = unsupported_dtd_type(TypeDesc)
+ ).
% Write out the DTD entries for all the given types and add the written
% types to AlreadyDone. Children types found along the way are added
% to the first argument. We stop when all the types have had their DTD
- % entry written. We also keep track of types assigned to the
- % `Unrecognised' element so we can print a comment about them in the
- % DTD.
- %
-:- pred write_dtd_types(list(type_desc)::in, map(type_desc, unit)::in,
- list(type_desc)::in, list(type_desc)::out, io::di, io::uo) is det.
-
-write_dtd_types([], _, Unrecognised, Unrecognised, !IO).
-write_dtd_types([TypeDesc | TypeDescs], AlreadyDone, Unrecognised0,
- Unrecognised, !IO) :-
+ % entry written.
+ %
+:- pred write_dtd_types(element_pred::in(element_pred),
+ list(type_desc)::in, map(type_desc, unit)::in,
+ io::di, io::uo) is det.
+
+write_dtd_types(_, [], _, !IO).
+write_dtd_types(MakeElement, [TypeDesc | TypeDescs], AlreadyDone, !IO) :-
(
map.search(AlreadyDone, TypeDesc, _)
->
- write_dtd_types(TypeDescs, AlreadyDone, Unrecognised0,
- Unrecognised, !IO)
+ write_dtd_types(MakeElement, TypeDescs, AlreadyDone, !IO)
;
- write_dtd_type_elements(TypeDesc, ChildArgTypes,
- IsUnrecognised, !IO),
- (
- IsUnrecognised = yes
- ->
- list.merge([TypeDesc], Unrecognised0, NewUnrecognised)
- ;
- NewUnrecognised = Unrecognised0
- ),
+ write_dtd_type_elements(MakeElement, TypeDesc, ChildArgTypes,
+ !IO),
map.set(AlreadyDone, TypeDesc, unit, NewAlreadyDone),
- write_dtd_types(append(ChildArgTypes, TypeDescs),
- NewAlreadyDone, NewUnrecognised, Unrecognised, !IO)
+ write_dtd_types(MakeElement, append(ChildArgTypes, TypeDescs),
+ NewAlreadyDone, !IO)
).
-:- pred write_unrecognised_dtd_element(io::di, io::uo) is det.
+:- pred write_attribute_source_kind(attribute_source::in, maybe(string)::in,
+ io::di, io::uo) is det.
-write_unrecognised_dtd_element(!IO) :-
- io.write_string("<!ELEMENT ", !IO),
- io.write_string(unrecognized_element, !IO),
- io.write_string(" ANY>\n", !IO),
- io.write_string("<!ATTLIST ", !IO),
- io.write_string(unrecognized_element, !IO),
- io.write_string(" functor CDATA #REQUIRED>\n", !IO),
- write_dtd_field_attlist(unrecognized_element, !IO),
- write_dtd_type_attlist(unrecognized_element, !IO).
+write_attribute_source_kind(functor, no, !IO) :-
+ io.write_string("#IMPLIED", !IO).
+write_attribute_source_kind(functor, yes(Value), !IO) :-
+ io.write_string("#FIXED """, !IO),
+ write_xml_escaped_string(Value, !IO),
+ io.write_string("""", !IO).
+write_attribute_source_kind(field_name, _, !IO) :-
+ io.write_string("#IMPLIED", !IO).
+write_attribute_source_kind(type_name, no, !IO) :-
+ io.write_string("#REQUIRED", !IO).
+write_attribute_source_kind(type_name, yes(Value), !IO) :-
+ io.write_string("#FIXED """, !IO),
+ write_xml_escaped_string(Value, !IO),
+ io.write_string("""", !IO).
+write_attribute_source_kind(arity, no, !IO) :-
+ io.write_string("#IMPLIED", !IO).
+write_attribute_source_kind(arity, yes(Value), !IO) :-
+ io.write_string("#FIXED """, !IO),
+ write_xml_escaped_string(Value, !IO),
+ io.write_string("""", !IO).
-:- pred write_dtd_field_attlist(string::in, io::di, io::uo) is det.
+:- pred write_dtd_attlist(string::in, maybe(string)::in, maybe(int)::in,
+ type_desc::in, attribute::in, io::di, io::uo) is det.
-write_dtd_field_attlist(Element, !IO) :-
+write_dtd_attlist(Element, MaybeFunctor, MaybeArity, TypeDesc,
+ attribute(Name, Source), !IO) :-
+ (
+ Source = functor,
+ MaybeValue = MaybeFunctor
+ ;
+ Source = arity,
+ (
+ MaybeArity = yes(Arity),
+ MaybeValue = yes(string.int_to_string(Arity))
+ ;
+ MaybeArity = no,
+ MaybeValue = no
+ )
+ ;
+ Source = type_name,
+ MaybeValue = yes(type_name(TypeDesc))
+ ;
+ Source = field_name,
+ MaybeValue = no
+ ),
io.write_string("<!ATTLIST ", !IO),
io.write_string(Element, !IO),
- io.write_string(" field CDATA #IMPLIED>\n", !IO).
+ io.write_string(" ", !IO),
+ io.write_string(Name, !IO),
+ io.write_string(" CDATA ", !IO),
+ write_attribute_source_kind(Source, MaybeValue, !IO),
+ io.write_string(">\n", !IO).
-:- pred write_dtd_type_attlist(string::in, io::di, io::uo) is det.
+:- pred write_dtd_attlists(string::in, list(attribute)::in, maybe(string)::in,
+ maybe(int)::in, type_desc::in, io::di, io::uo) is det.
-write_dtd_type_attlist(Element, !IO) :-
- io.write_string("<!ATTLIST ", !IO),
- io.write_string(Element, !IO),
- io.write_string(" typename CDATA #IMPLIED>\n", !IO).
+write_dtd_attlists(Element, Attributes, MaybeFunctor, MaybeArity, TypeDesc,
+ !IO) :-
+ list.foldl(write_dtd_attlist(Element, MaybeFunctor, MaybeArity,
+ TypeDesc), Attributes, !IO).
-:- pred write_dtd_type_elements(type_desc::in, list(type_desc)::out, bool::out,
- io::di, io::uo) is det.
+:- pred write_dtd_type_elements(element_pred::in(element_pred), type_desc::in,
+ list(type_desc)::out, io::di, io::uo) is det.
% Write DTD entries for all the functors for a type
%
-write_dtd_type_elements(TypeDesc, ChildArgTypes, IsUnrecognised, !IO) :-
- get_elements_and_args(TypeDesc, Elements, Functors, ArgTypeLists),
+write_dtd_type_elements(MakeElement, TypeDesc, ChildArgTypes, !IO) :-
+ get_elements_and_args(MakeElement, TypeDesc, Elements,
+ MaybeFunctors, MaybeArities, ArgTypeLists, AttributeLists),
list.condense(ArgTypeLists, ChildArgTypes),
- (
- % unrecognized elements don't have multiple functors.
- Elements \= [unrecognized_element]
- ->
- io.write_string("<!-- Elements for functors of type """, !IO),
- io.write_string(type_name(TypeDesc), !IO),
- io.write_string(""" -->\n\n", !IO),
- write_dtd_entries(TypeDesc, Elements, Functors,
- ArgTypeLists, !IO),
- IsUnrecognised = no
- ;
- IsUnrecognised = yes
- ).
-
-:- type term_to_xml_internal_error
- ---> term_to_xml_internal_error(string, string).
-
-:- pred write_dtd_entries(type_desc::in,
- list(string)::in, list(string)::in, list(list(type_desc))::in,
+ io.write_string("<!-- Elements for functors of type """, !IO),
+ write_xml_escaped_string(type_name(TypeDesc), !IO),
+ io.write_string(""" -->\n\n", !IO),
+ write_dtd_entries(MakeElement, TypeDesc, Elements, MaybeFunctors,
+ MaybeArities, ArgTypeLists, AttributeLists, !IO).
+
+:- pred write_dtd_entries(element_pred::in(element_pred), type_desc::in,
+ list(string)::in, list(maybe(string))::in, list(maybe(int))::in,
+ list(list(type_desc))::in, list(list(attribute))::in,
io::di, io::uo) is det.
% Write all the given DTD entries.
%
-write_dtd_entries(_, [], [], [], !IO).
-write_dtd_entries(TypeDesc, [Element | Elements], [Functor | Functors],
- [ArgTypeList | ArgTypeLists], !IO) :-
+write_dtd_entries(_, _, [], _, _, _, _, !IO).
+write_dtd_entries(MakeElement, TypeDesc, [Element | Elements],
+ MaybeFunctorList, MaybeArityList, ArgTypeListList,
+ AttributeListList, !IO) :-
+
+ MaybeFunctor = list.det_head(MaybeFunctorList),
+ MaybeFunctors = list.det_tail(MaybeFunctorList),
+ MaybeArity = list.det_head(MaybeArityList),
+ MaybeArities = list.det_tail(MaybeArityList),
+ ArgTypeList = list.det_head(ArgTypeListList),
+ ArgTypeLists = list.det_tail(ArgTypeListList),
+ AttributeList = list.det_head(AttributeListList),
+ AttributeLists = list.det_tail(AttributeListList),
+
io.write_string("<!ELEMENT ", !IO),
io.write_string(Element, !IO),
io.write_string(" ", !IO),
(
- ArgTypeList = [],
- io.write_string("EMPTY>\n", !IO)
+ is_primitive_type(TypeDesc, _)
+ ->
+ io.write_string("(#PCDATA)>\n", !IO)
;
- ArgTypeList = [Head | Tail],
(
- Tail = [_ | _],
- Braces = yes
+ ArgTypeList = [],
+ io.write_string("EMPTY>\n", !IO)
;
- Tail = [],
+ ArgTypeList = [Head | Tail],
(
- num_functors(Head) > 1
- ->
- Braces = no
- ;
+ Tail = [_ | _],
Braces = yes
- )
- ),
-
- % Put extra braces for arrays for the * at the end.
- ( is_array(TypeDesc, _) -> io.write_string("(", !IO) ; true ),
-
- ( Braces = yes, io.write_string("(", !IO) ; Braces = no ),
-
- io.write_list(ArgTypeList, ",",
- write_dtd_allowed_functors_regex, !IO),
-
- ( Braces = yes, io.write_string(")", !IO) ; Braces = no ),
-
- ( is_array(TypeDesc, _) -> io.write_string("*)", !IO) ; true ),
+ ;
+ Tail = [],
+ (
+ num_functors(Head) > 1
+ ->
+ Braces = no
+ ;
+ Braces = yes
+ )
+ ),
+
+ % Put extra braces for arrays for the * at the end.
+ ( is_array(TypeDesc, _) -> io.write_string("(", !IO)
+ ; true ),
+
+ ( Braces = yes, io.write_string("(", !IO)
+ ; Braces = no ),
+
+ io.write_list(ArgTypeList, ",",
+ write_dtd_allowed_functors_regex(MakeElement),
+ !IO),
+
+ ( Braces = yes, io.write_string(")", !IO)
+ ; Braces = no ),
+
+ ( is_array(TypeDesc, _) -> io.write_string("*)", !IO)
+ ; true ),
- io.write_string(">\n", !IO)
+ io.write_string(">\n", !IO)
+ )
),
- write_dtd_field_attlist(Element, !IO),
- write_dtd_type_attlist(Element, !IO),
- io.write_string("<!ATTLIST ", !IO),
- io.write_string(Element, !IO),
- io.write_string(" functor CDATA #FIXED """, !IO),
- write_xml_escaped_string(Functor, !IO),
- io.write_string(""">\n\n", !IO),
- write_dtd_entries(TypeDesc, Elements, Functors, ArgTypeLists,
- !IO).
-
-write_dtd_entries(_, [_ | _], [], [], !IO) :-
- throw(term_to_xml_internal_error("write_dtd_cons_elements",
- "lists not of equal length")).
-write_dtd_entries(_, [], [_ | _], [], !IO) :-
- throw(term_to_xml_internal_error("write_dtd_cons_elements",
- "lists not of equal length")).
-write_dtd_entries(_, [_ | _], [_ | _], [], !IO) :-
- throw(term_to_xml_internal_error("write_dtd_cons_elements",
- "lists not of equal length")).
-write_dtd_entries(_, [], [], [_ | _], !IO) :-
- throw(term_to_xml_internal_error("write_dtd_cons_elements",
- "lists not of equal length")).
-write_dtd_entries(_, [_ | _], [], [_ | _], !IO) :-
- throw(term_to_xml_internal_error("write_dtd_cons_elements",
- "lists not of equal length")).
-write_dtd_entries(_, [], [_ | _], [_ | _], !IO) :-
- throw(term_to_xml_internal_error("write_dtd_cons_elements",
- "lists not of equal length")).
+ write_dtd_attlists(Element, AttributeList, MaybeFunctor, MaybeArity,
+ TypeDesc, !IO),
+ io.nl(!IO),
+ write_dtd_entries(MakeElement, TypeDesc, Elements, MaybeFunctors,
+ MaybeArities, ArgTypeLists, AttributeLists, !IO).
% Write the allowed functors for the type as a DTD rule regular
% expression.
%
-:- pred write_dtd_allowed_functors_regex(type_desc::in, io::di, io::uo)
- is det.
+:- pred write_dtd_allowed_functors_regex(element_pred::in(element_pred),
+ type_desc::in, io::di, io::uo) is det.
-write_dtd_allowed_functors_regex(TypeDesc, !IO) :-
- get_elements_and_args(TypeDesc, Elements, _, _),
+write_dtd_allowed_functors_regex(MakeElement, TypeDesc, !IO) :-
+ get_elements_and_args(MakeElement, TypeDesc, Elements, _, _, _, _),
(
length(Elements) > 1
->
Index: scripts/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/scripts/Mmakefile,v
retrieving revision 1.32
diff -u -r1.32 Mmakefile
--- scripts/Mmakefile 15 May 2003 07:23:43 -0000 1.32
+++ scripts/Mmakefile 8 Dec 2004 14:37:06 -0000
@@ -18,7 +18,7 @@
mtags vpath_find mercury_update_interface \
mkfifo_using_mknod mercury_cleanup_install canonical_grade \
mercury_config mercury.bat
-DEBUGGER_SCRIPTS = mdbrc
+DEBUGGER_SCRIPTS = mdbrc ../extras/xml_stylesheets/xul_tree.xsl
EMACS_SCRIPTS = gud.el
#-----------------------------------------------------------------------------#
Index: scripts/mdbrc.in
===================================================================
RCS file: /home/mercury1/repository/mercury/scripts/mdbrc.in,v
retrieving revision 1.4
diff -u -r1.4 mdbrc.in
--- scripts/mdbrc.in 19 Jul 2000 01:35:01 -0000 1.4
+++ scripts/mdbrc.in 8 Dec 2004 14:37:06 -0000
@@ -15,3 +15,5 @@
alias e exception
alias EMPTY step
alias NUMBER step
+set xml_browser_cmd 'xsltproc @DEFAULT_MERCURY_DEBUGGER_INIT_DIR@/xul_tree.xsl /tmp/mdbtmp.xml > /tmp/mdbtmp.xul && mozilla file:///tmp/mdbtmp.xul'
+set xml_tmp_filename '/tmp/mdbtmp.xml'
Index: tests/debugger/browser_test.exp
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/browser_test.exp,v
retrieving revision 1.20
diff -u -r1.20 browser_test.exp
--- tests/debugger/browser_test.exp 16 Nov 2004 00:16:38 -0000 1.20
+++ tests/debugger/browser_test.exp 8 Dec 2004 15:27:28 -0000
@@ -106,6 +106,62 @@
3,
big(big(small, 4, big(small, 5, small)), 6, small))
browser> quit
+mdb> set xml_tmp_filename './tmp.xml'
+mdb> set xml_browser_cmd 'cat ./tmp.xml'
+mdb> browse --xml 1
+<?xml version="1.0"?>
+<big functor="big" type="browser_test.big" arity="3">
+ <big functor="big" type="browser_test.big" arity="3">
+ <big functor="big" type="browser_test.big" arity="3">
+ <small functor="small" type="browser_test.big" arity="0" />
+ <Int type="int">1</Int>
+ <small functor="small" type="browser_test.big" arity="0" />
+ </big>
+ <Int type="int">2</Int>
+ <small functor="small" type="browser_test.big" arity="0" />
+ </big>
+ <Int type="int">3</Int>
+ <big functor="big" type="browser_test.big" arity="3">
+ <big functor="big" type="browser_test.big" arity="3">
+ <small functor="small" type="browser_test.big" arity="0" />
+ <Int type="int">4</Int>
+ <big functor="big" type="browser_test.big" arity="3">
+ <small functor="small" type="browser_test.big" arity="0" />
+ <Int type="int">5</Int>
+ <small functor="small" type="browser_test.big" arity="0" />
+ </big>
+ </big>
+ <Int type="int">6</Int>
+ <small functor="small" type="browser_test.big" arity="0" />
+ </big>
+</big>
+mdb> browse -x Data
+<?xml version="1.0"?>
+<big functor="big" type="browser_test.big" arity="3">
+ <big functor="big" type="browser_test.big" arity="3">
+ <big functor="big" type="browser_test.big" arity="3">
+ <small functor="small" type="browser_test.big" arity="0" />
+ <Int type="int">1</Int>
+ <small functor="small" type="browser_test.big" arity="0" />
+ </big>
+ <Int type="int">2</Int>
+ <small functor="small" type="browser_test.big" arity="0" />
+ </big>
+ <Int type="int">3</Int>
+ <big functor="big" type="browser_test.big" arity="3">
+ <big functor="big" type="browser_test.big" arity="3">
+ <small functor="small" type="browser_test.big" arity="0" />
+ <Int type="int">4</Int>
+ <big functor="big" type="browser_test.big" arity="3">
+ <small functor="small" type="browser_test.big" arity="0" />
+ <Int type="int">5</Int>
+ <small functor="small" type="browser_test.big" arity="0" />
+ </big>
+ </big>
+ <Int type="int">6</Int>
+ <small functor="small" type="browser_test.big" arity="0" />
+ </big>
+</big>
mdb> set -A -f depth 1
mdb> print *
Data (arg 1) big(big/3, 3, big/3)
Index: tests/debugger/browser_test.inp
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/browser_test.inp,v
retrieving revision 1.11
diff -u -r1.11 browser_test.inp
--- tests/debugger/browser_test.inp 5 Nov 2004 06:30:20 -0000 1.11
+++ tests/debugger/browser_test.inp 8 Dec 2004 15:23:16 -0000
@@ -36,6 +36,10 @@
cdr 3 ../1/..
ls
quit
+set xml_tmp_filename './tmp.xml'
+set xml_browser_cmd 'cat ./tmp.xml'
+browse --xml 1
+browse -x Data
set -A -f depth 1
print *
print Data/1
Index: tests/hard_coded/write_xml.exp
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/write_xml.exp,v
retrieving revision 1.1
diff -u -r1.1 write_xml.exp
--- tests/hard_coded/write_xml.exp 7 Dec 2004 04:55:50 -0000 1.1
+++ tests/hard_coded/write_xml.exp 8 Dec 2004 10:25:16 -0000
@@ -1,470 +1,564 @@
+Result 1:
+unsupported_dtd_type(pred(int))
+
+<?xml version="1.0"?>
+<?xml-stylesheet type="text/css" href="http://www.cs.mu.oz.au/a_css.css"?>
+<Array--array-46array-40write_xml-46mytype-41 functor="<<array>>" type="array.array(write_xml.mytype)" arity="12">
+ <Tag_Tag-45--1--write_xml-46mytype functor="Tag-" type="write_xml.mytype" arity="1">
+ <Int type="int">44</Int>
+ </Tag_Tag-45--1--write_xml-46mytype>
+ <Tag_String--1--write_xml-46mytype functor="String" type="write_xml.mytype" arity="1">
+ <String type="string">a string</String>
+ </Tag_String--1--write_xml-46mytype>
+ <hello--5--write_xml-46mytype functor="hello" type="write_xml.mytype" arity="5">
+ <String type="string">this
+
+is a <string>&</String>
+ <Int type="int">-123</Int>
+ <Char type="character"><</Char>
+ <Float type="float">1.12300000000000</Float>
+ <yes--0--bool-46bool functor="yes" type="bool.bool" arity="0" />
+ </hello--5--write_xml-46mytype>
+ <a_tuple--1--write_xml-46mytype functor="a_tuple" type="write_xml.mytype" arity="1">
+ <Tuple--3--Tag_-123string-44-32int-44-32-123character-44-32float-125-125 functor="{}" type="{string, int, {character, float}}" arity="3">
+ <String type="string">some more stuf</String>
+ <Int type="int">123456</Int>
+ <Tuple--2--Tag_-123character-44-32float-125 functor="{}" type="{character, float}" arity="2">
+ <Char type="character">a</Char>
+ <Float type="float">1.23553225220000e-97</Float>
+ </Tuple--2--Tag_-123character-44-32float-125>
+ </Tuple--3--Tag_-123string-44-32int-44-32-123character-44-32float-125-125>
+ </a_tuple--1--write_xml-46mytype>
+ <Tag_List--1--write_xml-46mytype functor="List" type="write_xml.mytype" arity="1">
+ <List--2--list-46list-40write_xml-46listPart-41 functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <listPart--1--write_xml-46listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">1</Int>
+ </listPart--1--write_xml-46listPart>
+ <List--2--list-46list-40write_xml-46listPart-41 functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <listPart--1--write_xml-46listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">2</Int>
+ </listPart--1--write_xml-46listPart>
+ <List--2--list-46list-40write_xml-46listPart-41 functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <nothing--0--write_xml-46listPart functor="nothing" type="write_xml.listPart" arity="0" />
+ <List--2--list-46list-40write_xml-46listPart-41 functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <listPart--1--write_xml-46listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">4</Int>
+ </listPart--1--write_xml-46listPart>
+ <List--2--list-46list-40write_xml-46listPart-41 functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <nothing--0--write_xml-46listPart functor="nothing" type="write_xml.listPart" arity="0" />
+ <List--2--list-46list-40write_xml-46listPart-41 functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <listPart--1--write_xml-46listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">6</Int>
+ </listPart--1--write_xml-46listPart>
+ <List--2--list-46list-40write_xml-46listPart-41 functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <listPart--1--write_xml-46listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">7</Int>
+ </listPart--1--write_xml-46listPart>
+ <List--2--list-46list-40write_xml-46listPart-41 functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <listPart--1--write_xml-46listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">8</Int>
+ </listPart--1--write_xml-46listPart>
+ <List--2--list-46list-40write_xml-46listPart-41 functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <nothing--0--write_xml-46listPart functor="nothing" type="write_xml.listPart" arity="0" />
+ <Nil--0--list-46list-40write_xml-46listPart-41 functor="[]" type="list.list(write_xml.listPart)" arity="0" />
+ </List--2--list-46list-40write_xml-46listPart-41>
+ </List--2--list-46list-40write_xml-46listPart-41>
+ </List--2--list-46list-40write_xml-46listPart-41>
+ </List--2--list-46list-40write_xml-46listPart-41>
+ </List--2--list-46list-40write_xml-46listPart-41>
+ </List--2--list-46list-40write_xml-46listPart-41>
+ </List--2--list-46list-40write_xml-46listPart-41>
+ </List--2--list-46list-40write_xml-46listPart-41>
+ </List--2--list-46list-40write_xml-46listPart-41>
+ </Tag_List--1--write_xml-46mytype>
+ <a_map--1--write_xml-46mytype functor="a_map" type="write_xml.mytype" arity="1">
+ <four--10--tree234-46tree234-40int-44-32string-41 functor="four" type="tree234.tree234(int, string)" arity="10">
+ <Int type="int">2</Int>
+ <String type="string">hello1</String>
+ <Int type="int">4</Int>
+ <String type="string">hello3</String>
+ <Int type="int">6</Int>
+ <String type="string">hello5</String>
+ <two--4--tree234-46tree234-40int-44-32string-41 functor="two" type="tree234.tree234(int, string)" arity="4">
+ <Int type="int">1</Int>
+ <String type="string">hello</String>
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </two--4--tree234-46tree234-40int-44-32string-41>
+ <two--4--tree234-46tree234-40int-44-32string-41 functor="two" type="tree234.tree234(int, string)" arity="4">
+ <Int type="int">3</Int>
+ <String type="string">hello2</String>
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </two--4--tree234-46tree234-40int-44-32string-41>
+ <two--4--tree234-46tree234-40int-44-32string-41 functor="two" type="tree234.tree234(int, string)" arity="4">
+ <Int type="int">5</Int>
+ <String type="string">hello4</String>
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </two--4--tree234-46tree234-40int-44-32string-41>
+ <three--7--tree234-46tree234-40int-44-32string-41 functor="three" type="tree234.tree234(int, string)" arity="7">
+ <Int type="int">7</Int>
+ <String type="string">hello6</String>
+ <Int type="int">8</Int>
+ <String type="string">hello7</String>
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </three--7--tree234-46tree234-40int-44-32string-41>
+ </four--10--tree234-46tree234-40int-44-32string-41>
+ </a_map--1--write_xml-46mytype>
+ <a-32-60-33-64-35-36-37-94-38-42-40-41-62-32functor-32name-33-33-33--1--write_xml-46mytype functor="a <!@#$%^&*()> functor name!!!" type="write_xml.mytype" arity="1">
+ <Int type="int">999</Int>
+ </a-32-60-33-64-35-36-37-94-38-42-40-41-62-32functor-32name-33-33-33--1--write_xml-46mytype>
+ <a_pred--1--write_xml-46mytype functor="a_pred" type="write_xml.mytype" arity="1">
+ <pred-40int-41 functor="p" type="pred(int)" arity="3">
+ <Int type="int">1</Int>
+ <Int type="int">2</Int>
+ <hello--5--write_xml-46mytype functor="hello" type="write_xml.mytype" arity="5">
+ <String type="string">a string</String>
+ <Int type="int">1</Int>
+ <Char type="character">c</Char>
+ <Float type="float">-1.00000000000000e-15</Float>
+ <yes--0--bool-46bool functor="yes" type="bool.bool" arity="0" />
+ </hello--5--write_xml-46mytype>
+ </pred-40int-41>
+ </a_pred--1--write_xml-46mytype>
+ <t--1--write_xml-46mytype functor="t" type="write_xml.mytype" arity="1">
+ <type_desc-46type_desc functor="tree234" type="type_desc.type_desc" arity="2">
+ <type_desc-46type_desc functor="int" type="type_desc.type_desc" arity="0" />
+ <type_desc-46type_desc functor="string" type="type_desc.type_desc" arity="0" />
+ </type_desc-46type_desc>
+ </t--1--write_xml-46mytype>
+ <ctor--1--write_xml-46mytype functor="ctor" type="write_xml.mytype" arity="1">
+ <type_desc-46type_ctor_desc functor="tree234.tree234/2" type="type_desc.type_ctor_desc" arity="0" />
+ </ctor--1--write_xml-46mytype>
+ <foreign--1--write_xml-46mytype functor="foreign" type="write_xml.mytype" arity="1">
+ <write_xml-46ftype functor="<<foreign>>" type="write_xml.ftype" arity="0" />
+ </foreign--1--write_xml-46mytype>
+ <pointer--1--write_xml-46mytype functor="pointer" type="write_xml.mytype" arity="1">
+ <c_pointer functor="<<c_pointer>>" type="c_pointer" arity="0" />
+ </pointer--1--write_xml-46mytype>
+</Array--array-46array-40write_xml-46mytype-41>
+Result 2:
+ok
+
<?xml version="1.0"?>
<?xml-stylesheet type="text/css" href="http://www.cs.mu.oz.au/a_css.css"?>
-<!DOCTYPE Array--array-46array-40write_xml-46mytype-41 [
+<!DOCTYPE wrap--1--write_xml-46wrap-40tree234-46tree234-40int-44-32string-41-41 [
+
+<!-- Elements for functors of type "write_xml.wrap(tree234.tree234(int, string))" -->
-<!-- Builtin Mercury types -->
+<!ELEMENT wrap--1--write_xml-46wrap-40tree234-46tree234-40int-44-32string-41-41 (empty--0--tree234-46tree234-40int-44-32string-41|four--10--tree234-46tree234-40int-44-32string-41|three--7--tree234-46tree234-40int-44-32string-41|two--4--tree234-46tree234-40int-44-32string-41)>
+<!ATTLIST wrap--1--write_xml-46wrap-40tree234-46tree234-40int-44-32string-41-41 functor CDATA #FIXED "wrap">
+<!ATTLIST wrap--1--write_xml-46wrap-40tree234-46tree234-40int-44-32string-41-41 field CDATA #IMPLIED>
+<!ATTLIST wrap--1--write_xml-46wrap-40tree234-46tree234-40int-44-32string-41-41 type CDATA #FIXED "write_xml.wrap(tree234.tree234(int, string))">
+<!ATTLIST wrap--1--write_xml-46wrap-40tree234-46tree234-40int-44-32string-41-41 arity CDATA #FIXED "1">
+
+<!-- Elements for functors of type "tree234.tree234(int, string)" -->
+
+<!ELEMENT empty--0--tree234-46tree234-40int-44-32string-41 EMPTY>
+<!ATTLIST empty--0--tree234-46tree234-40int-44-32string-41 functor CDATA #FIXED "empty">
+<!ATTLIST empty--0--tree234-46tree234-40int-44-32string-41 field CDATA #IMPLIED>
+<!ATTLIST empty--0--tree234-46tree234-40int-44-32string-41 type CDATA #FIXED "tree234.tree234(int, string)">
+<!ATTLIST empty--0--tree234-46tree234-40int-44-32string-41 arity CDATA #FIXED "0">
+
+<!ELEMENT four--10--tree234-46tree234-40int-44-32string-41 (Int,String,Int,String,Int,String,(empty--0--tree234-46tree234-40int-44-32string-41|four--10--tree234-46tree234-40int-44-32string-41|three--7--tree234-46tree234-40int-44-32string-41|two--4--tree234-46tree234-40int-44-32string-41),(empty--0--tree234-46tree234-40int-44-32string-41|four--10--tree234-46tree234-40int-44-32string-41|three--7--tree234-46tree234-40int-44-32string-41|two--4--tree234-46tree234-40int-44-32string-41),(empty--0--tree234-46tree234-40int-44-32string-41|four--10--tree234-46tree234-40int-44-32string-41|three--7--tree234-46tree234-40int-44-32string-41|two--4--tree234-46tree234-40int-44-32string-41),(empty--0--tree234-46tree234-40int-44-32string-41|four--10--tree234-46tree234-40int-44-32string-41|three--7--tree234-46tree234-40int-44-32string-41|two--4--tree234-46tree234-40int-44-32string-41))>
+<!ATTLIST four--10--tree234-46tree234-40int-44-32string-41 functor CDATA #FIXED "four">
+<!ATTLIST four--10--tree234-46tree234-40int-44-32string-41 field CDATA #IMPLIED>
+<!ATTLIST four--10--tree234-46tree234-40int-44-32string-41 type CDATA #FIXED "tree234.tree234(int, string)">
+<!ATTLIST four--10--tree234-46tree234-40int-44-32string-41 arity CDATA #FIXED "10">
+
+<!ELEMENT three--7--tree234-46tree234-40int-44-32string-41 (Int,String,Int,String,(empty--0--tree234-46tree234-40int-44-32string-41|four--10--tree234-46tree234-40int-44-32string-41|three--7--tree234-46tree234-40int-44-32string-41|two--4--tree234-46tree234-40int-44-32string-41),(empty--0--tree234-46tree234-40int-44-32string-41|four--10--tree234-46tree234-40int-44-32string-41|three--7--tree234-46tree234-40int-44-32string-41|two--4--tree234-46tree234-40int-44-32string-41),(empty--0--tree234-46tree234-40int-44-32string-41|four--10--tree234-46tree234-40int-44-32string-41|three--7--tree234-46tree234-40int-44-32string-41|two--4--tree234-46tree234-40int-44-32string-41))>
+<!ATTLIST three--7--tree234-46tree234-40int-44-32string-41 functor CDATA #FIXED "three">
+<!ATTLIST three--7--tree234-46tree234-40int-44-32string-41 field CDATA #IMPLIED>
+<!ATTLIST three--7--tree234-46tree234-40int-44-32string-41 type CDATA #FIXED "tree234.tree234(int, string)">
+<!ATTLIST three--7--tree234-46tree234-40int-44-32string-41 arity CDATA #FIXED "7">
+
+<!ELEMENT two--4--tree234-46tree234-40int-44-32string-41 (Int,String,(empty--0--tree234-46tree234-40int-44-32string-41|four--10--tree234-46tree234-40int-44-32string-41|three--7--tree234-46tree234-40int-44-32string-41|two--4--tree234-46tree234-40int-44-32string-41),(empty--0--tree234-46tree234-40int-44-32string-41|four--10--tree234-46tree234-40int-44-32string-41|three--7--tree234-46tree234-40int-44-32string-41|two--4--tree234-46tree234-40int-44-32string-41))>
+<!ATTLIST two--4--tree234-46tree234-40int-44-32string-41 functor CDATA #FIXED "two">
+<!ATTLIST two--4--tree234-46tree234-40int-44-32string-41 field CDATA #IMPLIED>
+<!ATTLIST two--4--tree234-46tree234-40int-44-32string-41 type CDATA #FIXED "tree234.tree234(int, string)">
+<!ATTLIST two--4--tree234-46tree234-40int-44-32string-41 arity CDATA #FIXED "4">
+
+<!-- Elements for functors of type "int" -->
+
+<!ELEMENT Int (#PCDATA)>
+<!ATTLIST Int type CDATA #FIXED "int">
+<!ATTLIST Int field CDATA #IMPLIED>
+
+<!-- Elements for functors of type "string" -->
<!ELEMENT String (#PCDATA)>
+<!ATTLIST String type CDATA #FIXED "string">
<!ATTLIST String field CDATA #IMPLIED>
-<!ELEMENT Char (#PCDATA)>
-<!ATTLIST Char field CDATA #IMPLIED>
+
+
+]>
+<wrap--1--write_xml-46wrap-40tree234-46tree234-40int-44-32string-41-41 functor="wrap" type="write_xml.wrap(tree234.tree234(int, string))" arity="1">
+ <four--10--tree234-46tree234-40int-44-32string-41 functor="four" type="tree234.tree234(int, string)" arity="10">
+ <Int type="int">2</Int>
+ <String type="string">hello1</String>
+ <Int type="int">4</Int>
+ <String type="string">hello3</String>
+ <Int type="int">6</Int>
+ <String type="string">hello5</String>
+ <two--4--tree234-46tree234-40int-44-32string-41 functor="two" type="tree234.tree234(int, string)" arity="4">
+ <Int type="int">1</Int>
+ <String type="string">hello</String>
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </two--4--tree234-46tree234-40int-44-32string-41>
+ <two--4--tree234-46tree234-40int-44-32string-41 functor="two" type="tree234.tree234(int, string)" arity="4">
+ <Int type="int">3</Int>
+ <String type="string">hello2</String>
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </two--4--tree234-46tree234-40int-44-32string-41>
+ <two--4--tree234-46tree234-40int-44-32string-41 functor="two" type="tree234.tree234(int, string)" arity="4">
+ <Int type="int">5</Int>
+ <String type="string">hello4</String>
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </two--4--tree234-46tree234-40int-44-32string-41>
+ <three--7--tree234-46tree234-40int-44-32string-41 functor="three" type="tree234.tree234(int, string)" arity="7">
+ <Int type="int">7</Int>
+ <String type="string">hello6</String>
+ <Int type="int">8</Int>
+ <String type="string">hello7</String>
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty--0--tree234-46tree234-40int-44-32string-41 functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </three--7--tree234-46tree234-40int-44-32string-41>
+ </four--10--tree234-46tree234-40int-44-32string-41>
+</wrap--1--write_xml-46wrap-40tree234-46tree234-40int-44-32string-41-41>
+Result 3:
+ok
+
+<?xml version="1.0"?>
+<?xml-stylesheet type="text/css" href="http://www.cs.mu.oz.au/a_css.css"?>
+<!DOCTYPE wrap [
+
+<!-- Elements for functors of type "write_xml.wrap(tree234.tree234(int, string))" -->
+
+<!ELEMENT wrap (empty|four|three|two)>
+<!ATTLIST wrap functor CDATA #FIXED "wrap">
+<!ATTLIST wrap field CDATA #IMPLIED>
+<!ATTLIST wrap type CDATA #FIXED "write_xml.wrap(tree234.tree234(int, string))">
+<!ATTLIST wrap arity CDATA #FIXED "1">
+
+<!-- Elements for functors of type "tree234.tree234(int, string)" -->
+
+<!ELEMENT empty EMPTY>
+<!ATTLIST empty functor CDATA #FIXED "empty">
+<!ATTLIST empty field CDATA #IMPLIED>
+<!ATTLIST empty type CDATA #FIXED "tree234.tree234(int, string)">
+<!ATTLIST empty arity CDATA #FIXED "0">
+
+<!ELEMENT four (Int,String,Int,String,Int,String,(empty|four|three|two),(empty|four|three|two),(empty|four|three|two),(empty|four|three|two))>
+<!ATTLIST four functor CDATA #FIXED "four">
+<!ATTLIST four field CDATA #IMPLIED>
+<!ATTLIST four type CDATA #FIXED "tree234.tree234(int, string)">
+<!ATTLIST four arity CDATA #FIXED "10">
+
+<!ELEMENT three (Int,String,Int,String,(empty|four|three|two),(empty|four|three|two),(empty|four|three|two))>
+<!ATTLIST three functor CDATA #FIXED "three">
+<!ATTLIST three field CDATA #IMPLIED>
+<!ATTLIST three type CDATA #FIXED "tree234.tree234(int, string)">
+<!ATTLIST three arity CDATA #FIXED "7">
+
+<!ELEMENT two (Int,String,(empty|four|three|two),(empty|four|three|two))>
+<!ATTLIST two functor CDATA #FIXED "two">
+<!ATTLIST two field CDATA #IMPLIED>
+<!ATTLIST two type CDATA #FIXED "tree234.tree234(int, string)">
+<!ATTLIST two arity CDATA #FIXED "4">
+
+<!-- Elements for functors of type "int" -->
+
<!ELEMENT Int (#PCDATA)>
+<!ATTLIST Int type CDATA #FIXED "int">
<!ATTLIST Int field CDATA #IMPLIED>
-<!ELEMENT Float (#PCDATA)>
-<!ATTLIST Float field CDATA #IMPLIED>
-<!-- Elements for functors of type "array.array(write_xml.mytype)" -->
+<!-- Elements for functors of type "string" -->
+
+<!ELEMENT String (#PCDATA)>
+<!ATTLIST String type CDATA #FIXED "string">
+<!ATTLIST String field CDATA #IMPLIED>
+
+
+]>
+<wrap functor="wrap" type="write_xml.wrap(tree234.tree234(int, string))" arity="1">
+ <four functor="four" type="tree234.tree234(int, string)" arity="10">
+ <Int type="int">2</Int>
+ <String type="string">hello1</String>
+ <Int type="int">4</Int>
+ <String type="string">hello3</String>
+ <Int type="int">6</Int>
+ <String type="string">hello5</String>
+ <two functor="two" type="tree234.tree234(int, string)" arity="4">
+ <Int type="int">1</Int>
+ <String type="string">hello</String>
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </two>
+ <two functor="two" type="tree234.tree234(int, string)" arity="4">
+ <Int type="int">3</Int>
+ <String type="string">hello2</String>
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </two>
+ <two functor="two" type="tree234.tree234(int, string)" arity="4">
+ <Int type="int">5</Int>
+ <String type="string">hello4</String>
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </two>
+ <three functor="three" type="tree234.tree234(int, string)" arity="7">
+ <Int type="int">7</Int>
+ <String type="string">hello6</String>
+ <Int type="int">8</Int>
+ <String type="string">hello7</String>
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </three>
+ </four>
+</wrap>
+Result 3_1:
+ok
+
+<?xml version="1.0"?>
+<?xml-stylesheet type="text/css" href="http://www.cs.mu.oz.au/a_css.css"?>
+<!DOCTYPE Array--array-46array-40write_xml-46listPart-41 [
+
+<!-- Elements for functors of type "array.array(write_xml.listPart)" -->
-<!ELEMENT Array--array-46array-40write_xml-46mytype-41 ((Tag_List--write_xml-46mytype|Tag_String--write_xml-46mytype|Tag_Tag-45--write_xml-46mytype|a-32-60-33-64-35-36-37-94-38-42-40-41-62-32functor-32name-33-33-33--write_xml-46mytype|a_map--write_xml-46mytype|a_pred--write_xml-46mytype|a_tuple--write_xml-46mytype|ctor--write_xml-46mytype|foreign--write_xml-46mytype|hello--write_xml-46mytype|pointer--write_xml-46mytype|t--write_xml-46mytype)*)>
-<!ATTLIST Array--array-46array-40write_xml-46mytype-41 field CDATA #IMPLIED>
-<!ATTLIST Array--array-46array-40write_xml-46mytype-41 typename CDATA #IMPLIED>
-<!ATTLIST Array--array-46array-40write_xml-46mytype-41 functor CDATA #FIXED "<<array>>">
-
-<!-- Elements for functors of type "write_xml.mytype" -->
-
-<!ELEMENT Tag_List--write_xml-46mytype (Nil--list-46list-40write_xml-46listPart-41|List--list-46list-40write_xml-46listPart-41)>
-<!ATTLIST Tag_List--write_xml-46mytype field CDATA #IMPLIED>
-<!ATTLIST Tag_List--write_xml-46mytype typename CDATA #IMPLIED>
-<!ATTLIST Tag_List--write_xml-46mytype functor CDATA #FIXED "List">
-
-<!ELEMENT Tag_String--write_xml-46mytype (String)>
-<!ATTLIST Tag_String--write_xml-46mytype field CDATA #IMPLIED>
-<!ATTLIST Tag_String--write_xml-46mytype typename CDATA #IMPLIED>
-<!ATTLIST Tag_String--write_xml-46mytype functor CDATA #FIXED "String">
-
-<!ELEMENT Tag_Tag-45--write_xml-46mytype (Int)>
-<!ATTLIST Tag_Tag-45--write_xml-46mytype field CDATA #IMPLIED>
-<!ATTLIST Tag_Tag-45--write_xml-46mytype typename CDATA #IMPLIED>
-<!ATTLIST Tag_Tag-45--write_xml-46mytype functor CDATA #FIXED "Tag-">
-
-<!ELEMENT a-32-60-33-64-35-36-37-94-38-42-40-41-62-32functor-32name-33-33-33--write_xml-46mytype (Int)>
-<!ATTLIST a-32-60-33-64-35-36-37-94-38-42-40-41-62-32functor-32name-33-33-33--write_xml-46mytype field CDATA #IMPLIED>
-<!ATTLIST a-32-60-33-64-35-36-37-94-38-42-40-41-62-32functor-32name-33-33-33--write_xml-46mytype typename CDATA #IMPLIED>
-<!ATTLIST a-32-60-33-64-35-36-37-94-38-42-40-41-62-32functor-32name-33-33-33--write_xml-46mytype functor CDATA #FIXED "a <!@#$%^&*()> functor name!!!">
-
-<!ELEMENT a_map--write_xml-46mytype (empty--tree234-46tree234-40int-44-32string-41|four--tree234-46tree234-40int-44-32string-41|three--tree234-46tree234-40int-44-32string-41|two--tree234-46tree234-40int-44-32string-41)>
-<!ATTLIST a_map--write_xml-46mytype field CDATA #IMPLIED>
-<!ATTLIST a_map--write_xml-46mytype typename CDATA #IMPLIED>
-<!ATTLIST a_map--write_xml-46mytype functor CDATA #FIXED "a_map">
-
-<!ELEMENT a_pred--write_xml-46mytype (Unrecognized)>
-<!ATTLIST a_pred--write_xml-46mytype field CDATA #IMPLIED>
-<!ATTLIST a_pred--write_xml-46mytype typename CDATA #IMPLIED>
-<!ATTLIST a_pred--write_xml-46mytype functor CDATA #FIXED "a_pred">
-
-<!ELEMENT a_tuple--write_xml-46mytype (Tuple--Tag_-123string-44-32int-44-32-123character-44-32float-125-125)>
-<!ATTLIST a_tuple--write_xml-46mytype field CDATA #IMPLIED>
-<!ATTLIST a_tuple--write_xml-46mytype typename CDATA #IMPLIED>
-<!ATTLIST a_tuple--write_xml-46mytype functor CDATA #FIXED "a_tuple">
-
-<!ELEMENT ctor--write_xml-46mytype (Unrecognized)>
-<!ATTLIST ctor--write_xml-46mytype field CDATA #IMPLIED>
-<!ATTLIST ctor--write_xml-46mytype typename CDATA #IMPLIED>
-<!ATTLIST ctor--write_xml-46mytype functor CDATA #FIXED "ctor">
-
-<!ELEMENT foreign--write_xml-46mytype (Unrecognized)>
-<!ATTLIST foreign--write_xml-46mytype field CDATA #IMPLIED>
-<!ATTLIST foreign--write_xml-46mytype typename CDATA #IMPLIED>
-<!ATTLIST foreign--write_xml-46mytype functor CDATA #FIXED "foreign">
-
-<!ELEMENT hello--write_xml-46mytype (String,Int,Char,Float,(no--bool-46bool|yes--bool-46bool))>
-<!ATTLIST hello--write_xml-46mytype field CDATA #IMPLIED>
-<!ATTLIST hello--write_xml-46mytype typename CDATA #IMPLIED>
-<!ATTLIST hello--write_xml-46mytype functor CDATA #FIXED "hello">
-
-<!ELEMENT pointer--write_xml-46mytype (Unrecognized)>
-<!ATTLIST pointer--write_xml-46mytype field CDATA #IMPLIED>
-<!ATTLIST pointer--write_xml-46mytype typename CDATA #IMPLIED>
-<!ATTLIST pointer--write_xml-46mytype functor CDATA #FIXED "pointer">
-
-<!ELEMENT t--write_xml-46mytype (Unrecognized)>
-<!ATTLIST t--write_xml-46mytype field CDATA #IMPLIED>
-<!ATTLIST t--write_xml-46mytype typename CDATA #IMPLIED>
-<!ATTLIST t--write_xml-46mytype functor CDATA #FIXED "t">
-
-<!-- Elements for functors of type "list.list(write_xml.listPart)" -->
-
-<!ELEMENT Nil--list-46list-40write_xml-46listPart-41 EMPTY>
-<!ATTLIST Nil--list-46list-40write_xml-46listPart-41 field CDATA #IMPLIED>
-<!ATTLIST Nil--list-46list-40write_xml-46listPart-41 typename CDATA #IMPLIED>
-<!ATTLIST Nil--list-46list-40write_xml-46listPart-41 functor CDATA #FIXED "[]">
-
-<!ELEMENT List--list-46list-40write_xml-46listPart-41 ((listPart--write_xml-46listPart|nothing--write_xml-46listPart),(Nil--list-46list-40write_xml-46listPart-41|List--list-46list-40write_xml-46listPart-41))>
-<!ATTLIST List--list-46list-40write_xml-46listPart-41 field CDATA #IMPLIED>
-<!ATTLIST List--list-46list-40write_xml-46listPart-41 typename CDATA #IMPLIED>
-<!ATTLIST List--list-46list-40write_xml-46listPart-41 functor CDATA #FIXED "[|]">
+<!ELEMENT Array--array-46array-40write_xml-46listPart-41 ((listPart--1--write_xml-46listPart|nothing--0--write_xml-46listPart)*)>
+<!ATTLIST Array--array-46array-40write_xml-46listPart-41 functor CDATA #IMPLIED>
+<!ATTLIST Array--array-46array-40write_xml-46listPart-41 field CDATA #IMPLIED>
+<!ATTLIST Array--array-46array-40write_xml-46listPart-41 type CDATA #FIXED "array.array(write_xml.listPart)">
+<!ATTLIST Array--array-46array-40write_xml-46listPart-41 arity CDATA #IMPLIED>
<!-- Elements for functors of type "write_xml.listPart" -->
-<!ELEMENT listPart--write_xml-46listPart (Int)>
-<!ATTLIST listPart--write_xml-46listPart field CDATA #IMPLIED>
-<!ATTLIST listPart--write_xml-46listPart typename CDATA #IMPLIED>
-<!ATTLIST listPart--write_xml-46listPart functor CDATA #FIXED "listPart">
-
-<!ELEMENT nothing--write_xml-46listPart EMPTY>
-<!ATTLIST nothing--write_xml-46listPart field CDATA #IMPLIED>
-<!ATTLIST nothing--write_xml-46listPart typename CDATA #IMPLIED>
-<!ATTLIST nothing--write_xml-46listPart functor CDATA #FIXED "nothing">
+<!ELEMENT listPart--1--write_xml-46listPart (Int)>
+<!ATTLIST listPart--1--write_xml-46listPart functor CDATA #FIXED "listPart">
+<!ATTLIST listPart--1--write_xml-46listPart field CDATA #IMPLIED>
+<!ATTLIST listPart--1--write_xml-46listPart type CDATA #FIXED "write_xml.listPart">
+<!ATTLIST listPart--1--write_xml-46listPart arity CDATA #FIXED "1">
+
+<!ELEMENT nothing--0--write_xml-46listPart EMPTY>
+<!ATTLIST nothing--0--write_xml-46listPart functor CDATA #FIXED "nothing">
+<!ATTLIST nothing--0--write_xml-46listPart field CDATA #IMPLIED>
+<!ATTLIST nothing--0--write_xml-46listPart type CDATA #FIXED "write_xml.listPart">
+<!ATTLIST nothing--0--write_xml-46listPart arity CDATA #FIXED "0">
-<!-- Elements for functors of type "tree234.tree234(int, string)" -->
+<!-- Elements for functors of type "int" -->
-<!ELEMENT empty--tree234-46tree234-40int-44-32string-41 EMPTY>
-<!ATTLIST empty--tree234-46tree234-40int-44-32string-41 field CDATA #IMPLIED>
-<!ATTLIST empty--tree234-46tree234-40int-44-32string-41 typename CDATA #IMPLIED>
-<!ATTLIST empty--tree234-46tree234-40int-44-32string-41 functor CDATA #FIXED "empty">
-
-<!ELEMENT four--tree234-46tree234-40int-44-32string-41 (Int,String,Int,String,Int,String,(empty--tree234-46tree234-40int-44-32string-41|four--tree234-46tree234-40int-44-32string-41|three--tree234-46tree234-40int-44-32string-41|two--tree234-46tree234-40int-44-32string-41),(empty--tree234-46tree234-40int-44-32string-41|four--tree234-46tree234-40int-44-32string-41|three--tree234-46tree234-40int-44-32string-41|two--tree234-46tree234-40int-44-32string-41),(empty--tree234-46tree234-40int-44-32string-41|four--tree234-46tree234-40int-44-32string-41|three--tree234-46tree234-40int-44-32string-41|two--tree234-46tree234-40int-44-32string-41),(empty--tree234-46tree234-40int-44-32string-41|four--tree234-46tree234-40int-44-32string-41|three--tree234-46tree234-40int-44-32string-41|two--tree234-46tree234-40int-44-32string-41))>
-<!ATTLIST four--tree234-46tree234-40int-44-32string-41 field CDATA #IMPLIED>
-<!ATTLIST four--tree234-46tree234-40int-44-32string-41 typename CDATA #IMPLIED>
-<!ATTLIST four--tree234-46tree234-40int-44-32string-41 functor CDATA #FIXED "four">
-
-<!ELEMENT three--tree234-46tree234-40int-44-32string-41 (Int,String,Int,String,(empty--tree234-46tree234-40int-44-32string-41|four--tree234-46tree234-40int-44-32string-41|three--tree234-46tree234-40int-44-32string-41|two--tree234-46tree234-40int-44-32string-41),(empty--tree234-46tree234-40int-44-32string-41|four--tree234-46tree234-40int-44-32string-41|three--tree234-46tree234-40int-44-32string-41|two--tree234-46tree234-40int-44-32string-41),(empty--tree234-46tree234-40int-44-32string-41|four--tree234-46tree234-40int-44-32string-41|three--tree234-46tree234-40int-44-32string-41|two--tree234-46tree234-40int-44-32string-41))>
-<!ATTLIST three--tree234-46tree234-40int-44-32string-41 field CDATA #IMPLIED>
-<!ATTLIST three--tree234-46tree234-40int-44-32string-41 typename CDATA #IMPLIED>
-<!ATTLIST three--tree234-46tree234-40int-44-32string-41 functor CDATA #FIXED "three">
-
-<!ELEMENT two--tree234-46tree234-40int-44-32string-41 (Int,String,(empty--tree234-46tree234-40int-44-32string-41|four--tree234-46tree234-40int-44-32string-41|three--tree234-46tree234-40int-44-32string-41|two--tree234-46tree234-40int-44-32string-41),(empty--tree234-46tree234-40int-44-32string-41|four--tree234-46tree234-40int-44-32string-41|three--tree234-46tree234-40int-44-32string-41|two--tree234-46tree234-40int-44-32string-41))>
-<!ATTLIST two--tree234-46tree234-40int-44-32string-41 field CDATA #IMPLIED>
-<!ATTLIST two--tree234-46tree234-40int-44-32string-41 typename CDATA #IMPLIED>
-<!ATTLIST two--tree234-46tree234-40int-44-32string-41 functor CDATA #FIXED "two">
-
-<!-- Elements for functors of type "{string, int, {character, float}}" -->
-
-<!ELEMENT Tuple--Tag_-123string-44-32int-44-32-123character-44-32float-125-125 (String,Int,Tuple--Tag_-123character-44-32float-125)>
-<!ATTLIST Tuple--Tag_-123string-44-32int-44-32-123character-44-32float-125-125 field CDATA #IMPLIED>
-<!ATTLIST Tuple--Tag_-123string-44-32int-44-32-123character-44-32float-125-125 typename CDATA #IMPLIED>
-<!ATTLIST Tuple--Tag_-123string-44-32int-44-32-123character-44-32float-125-125 functor CDATA #FIXED "{}">
-
-<!-- Elements for functors of type "{character, float}" -->
-
-<!ELEMENT Tuple--Tag_-123character-44-32float-125 (Char,Float)>
-<!ATTLIST Tuple--Tag_-123character-44-32float-125 field CDATA #IMPLIED>
-<!ATTLIST Tuple--Tag_-123character-44-32float-125 typename CDATA #IMPLIED>
-<!ATTLIST Tuple--Tag_-123character-44-32float-125 functor CDATA #FIXED "{}">
-
-<!-- Elements for functors of type "bool.bool" -->
-
-<!ELEMENT no--bool-46bool EMPTY>
-<!ATTLIST no--bool-46bool field CDATA #IMPLIED>
-<!ATTLIST no--bool-46bool typename CDATA #IMPLIED>
-<!ATTLIST no--bool-46bool functor CDATA #FIXED "no">
-
-<!ELEMENT yes--bool-46bool EMPTY>
-<!ATTLIST yes--bool-46bool field CDATA #IMPLIED>
-<!ATTLIST yes--bool-46bool typename CDATA #IMPLIED>
-<!ATTLIST yes--bool-46bool functor CDATA #FIXED "yes">
-
-<!-- The following types have been assigned to the `Unrecognised' element:
- c_pointer
- pred(int)
- type_desc.type_ctor_desc
- type_desc.type_desc
- write_xml.ftype
--->
-
-<!ELEMENT Unrecognized ANY>
-<!ATTLIST Unrecognized functor CDATA #REQUIRED>
-<!ATTLIST Unrecognized field CDATA #IMPLIED>
-<!ATTLIST Unrecognized typename CDATA #IMPLIED>
+<!ELEMENT Int (#PCDATA)>
+<!ATTLIST Int type CDATA #FIXED "int">
+<!ATTLIST Int field CDATA #IMPLIED>
-]>
-<Array--array-46array-40write_xml-46mytype-41 functor="<<array>>" typename="array.array(write_xml.mytype)">
- <Tag_Tag-45--write_xml-46mytype functor="Tag-" typename="write_xml.mytype">
- <Int>44</Int>
- </Tag_Tag-45--write_xml-46mytype>
- <Tag_String--write_xml-46mytype functor="String" typename="write_xml.mytype">
- <String>a string</String>
- </Tag_String--write_xml-46mytype>
- <hello--write_xml-46mytype functor="hello" typename="write_xml.mytype">
- <String field="field1">this
-is a <string>&</String>
- <Int field="Field<2>">-123</Int>
- <Char><</Char>
- <Float field="another field">1.12300000000000</Float>
- <yes--bool-46bool functor="yes" typename="bool.bool" />
- </hello--write_xml-46mytype>
- <a_tuple--write_xml-46mytype functor="a_tuple" typename="write_xml.mytype">
- <Tuple--Tag_-123string-44-32int-44-32-123character-44-32float-125-125 functor="{}" typename="{string, int, {character, float}}">
- <String>some more stuf</String>
- <Int>123456</Int>
- <Tuple--Tag_-123character-44-32float-125 functor="{}" typename="{character, float}">
- <Char>a</Char>
- <Float>1.23553225220000e-97</Float>
- </Tuple--Tag_-123character-44-32float-125>
- </Tuple--Tag_-123string-44-32int-44-32-123character-44-32float-125-125>
- </a_tuple--write_xml-46mytype>
- <Tag_List--write_xml-46mytype functor="List" typename="write_xml.mytype">
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
- <Int>1</Int>
- </listPart--write_xml-46listPart>
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
- <Int>2</Int>
- </listPart--write_xml-46listPart>
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <nothing--write_xml-46listPart functor="nothing" typename="write_xml.listPart" />
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
- <Int>4</Int>
- </listPart--write_xml-46listPart>
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <nothing--write_xml-46listPart functor="nothing" typename="write_xml.listPart" />
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
- <Int>6</Int>
- </listPart--write_xml-46listPart>
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
- <Int>7</Int>
- </listPart--write_xml-46listPart>
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
- <Int>8</Int>
- </listPart--write_xml-46listPart>
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <nothing--write_xml-46listPart functor="nothing" typename="write_xml.listPart" />
- <Nil--list-46list-40write_xml-46listPart-41 functor="[]" typename="list.list(write_xml.listPart)" />
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </Tag_List--write_xml-46mytype>
- <a_map--write_xml-46mytype functor="a_map" typename="write_xml.mytype">
- <four--tree234-46tree234-40int-44-32string-41 functor="four" typename="tree234.tree234(int, string)">
- <Int>2</Int>
- <String>hello1</String>
- <Int>4</Int>
- <String>hello3</String>
- <Int>6</Int>
- <String>hello5</String>
- <two--tree234-46tree234-40int-44-32string-41 functor="two" typename="tree234.tree234(int, string)">
- <Int>1</Int>
- <String>hello</String>
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- </two--tree234-46tree234-40int-44-32string-41>
- <two--tree234-46tree234-40int-44-32string-41 functor="two" typename="tree234.tree234(int, string)">
- <Int>3</Int>
- <String>hello2</String>
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- </two--tree234-46tree234-40int-44-32string-41>
- <two--tree234-46tree234-40int-44-32string-41 functor="two" typename="tree234.tree234(int, string)">
- <Int>5</Int>
- <String>hello4</String>
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- </two--tree234-46tree234-40int-44-32string-41>
- <three--tree234-46tree234-40int-44-32string-41 functor="three" typename="tree234.tree234(int, string)">
- <Int>7</Int>
- <String>hello6</String>
- <Int>8</Int>
- <String>hello7</String>
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- </three--tree234-46tree234-40int-44-32string-41>
- </four--tree234-46tree234-40int-44-32string-41>
- </a_map--write_xml-46mytype>
- <a-32-60-33-64-35-36-37-94-38-42-40-41-62-32functor-32name-33-33-33--write_xml-46mytype functor="a <!@#$%^&*()> functor name!!!" typename="write_xml.mytype">
- <Int>999</Int>
- </a-32-60-33-64-35-36-37-94-38-42-40-41-62-32functor-32name-33-33-33--write_xml-46mytype>
- <a_pred--write_xml-46mytype functor="a_pred" typename="write_xml.mytype">
- <Unrecognized functor="p" typename="pred(int)">
- <Int>1</Int>
- <Int>2</Int>
- <hello--write_xml-46mytype functor="hello" typename="write_xml.mytype">
- <String field="field1">a string</String>
- <Int field="Field<2>">1</Int>
- <Char>c</Char>
- <Float field="another field">-1.00000000000000e-15</Float>
- <yes--bool-46bool functor="yes" typename="bool.bool" />
- </hello--write_xml-46mytype>
- </Unrecognized>
- </a_pred--write_xml-46mytype>
- <t--write_xml-46mytype functor="t" typename="write_xml.mytype">
- <Unrecognized functor="tree234" typename="type_desc.type_desc">
- <Unrecognized functor="int" typename="type_desc.type_desc" />
- <Unrecognized functor="string" typename="type_desc.type_desc" />
- </Unrecognized>
- </t--write_xml-46mytype>
- <ctor--write_xml-46mytype functor="ctor" typename="write_xml.mytype">
- <Unrecognized functor="tree234.tree234/2" typename="type_desc.type_ctor_desc" />
- </ctor--write_xml-46mytype>
- <foreign--write_xml-46mytype functor="foreign" typename="write_xml.mytype">
- <Unrecognized functor="<<foreign>>" typename="write_xml.ftype" />
- </foreign--write_xml-46mytype>
- <pointer--write_xml-46mytype functor="pointer" typename="write_xml.mytype">
- <Unrecognized functor="<<c_pointer>>" typename="c_pointer" />
- </pointer--write_xml-46mytype>
-</Array--array-46array-40write_xml-46mytype-41>
+]>
+<Array--array-46array-40write_xml-46listPart-41 functor="<<array>>" type="array.array(write_xml.listPart)" arity="9">
+ <listPart--1--write_xml-46listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">1</Int>
+ </listPart--1--write_xml-46listPart>
+ <listPart--1--write_xml-46listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">2</Int>
+ </listPart--1--write_xml-46listPart>
+ <nothing--0--write_xml-46listPart functor="nothing" type="write_xml.listPart" arity="0" />
+ <listPart--1--write_xml-46listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">4</Int>
+ </listPart--1--write_xml-46listPart>
+ <nothing--0--write_xml-46listPart functor="nothing" type="write_xml.listPart" arity="0" />
+ <listPart--1--write_xml-46listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">6</Int>
+ </listPart--1--write_xml-46listPart>
+ <listPart--1--write_xml-46listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">7</Int>
+ </listPart--1--write_xml-46listPart>
+ <listPart--1--write_xml-46listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">8</Int>
+ </listPart--1--write_xml-46listPart>
+ <nothing--0--write_xml-46listPart functor="nothing" type="write_xml.listPart" arity="0" />
+</Array--array-46array-40write_xml-46listPart-41>
+Result 4:
ok
<?xml version="1.0"?>
-<!DOCTYPE List--list-46list-40write_xml-46mytype-41 PUBLIC "test" "test.dtd">
-<List--list-46list-40write_xml-46mytype-41 functor="[|]" typename="list.list(write_xml.mytype)">
- <Tag_Tag-45--write_xml-46mytype functor="Tag-" typename="write_xml.mytype">
- <Int>44</Int>
- </Tag_Tag-45--write_xml-46mytype>
- <List--list-46list-40write_xml-46mytype-41 functor="[|]" typename="list.list(write_xml.mytype)">
- <Tag_String--write_xml-46mytype functor="String" typename="write_xml.mytype">
- <String>a string</String>
- </Tag_String--write_xml-46mytype>
- <List--list-46list-40write_xml-46mytype-41 functor="[|]" typename="list.list(write_xml.mytype)">
- <hello--write_xml-46mytype functor="hello" typename="write_xml.mytype">
- <String field="field1">this
+<!DOCTYPE List PUBLIC "test" "test.dtd">
+<List functor="[|]" type="list.list(write_xml.mytype)" arity="2">
+ <Tag_Tag-45 functor="Tag-" type="write_xml.mytype" arity="1">
+ <Int type="int">44</Int>
+ </Tag_Tag-45>
+ <List functor="[|]" type="list.list(write_xml.mytype)" arity="2">
+ <Tag_String functor="String" type="write_xml.mytype" arity="1">
+ <String type="string">a string</String>
+ </Tag_String>
+ <List functor="[|]" type="list.list(write_xml.mytype)" arity="2">
+ <hello functor="hello" type="write_xml.mytype" arity="5">
+ <String type="string">this
is a <string>&</String>
- <Int field="Field<2>">-123</Int>
- <Char><</Char>
- <Float field="another field">1.12300000000000</Float>
- <yes--bool-46bool functor="yes" typename="bool.bool" />
- </hello--write_xml-46mytype>
- <List--list-46list-40write_xml-46mytype-41 functor="[|]" typename="list.list(write_xml.mytype)">
- <a_tuple--write_xml-46mytype functor="a_tuple" typename="write_xml.mytype">
- <Tuple--Tag_-123string-44-32int-44-32-123character-44-32float-125-125 functor="{}" typename="{string, int, {character, float}}">
- <String>some more stuf</String>
- <Int>123456</Int>
- <Tuple--Tag_-123character-44-32float-125 functor="{}" typename="{character, float}">
- <Char>a</Char>
- <Float>1.23553225220000e-97</Float>
- </Tuple--Tag_-123character-44-32float-125>
- </Tuple--Tag_-123string-44-32int-44-32-123character-44-32float-125-125>
- </a_tuple--write_xml-46mytype>
- <List--list-46list-40write_xml-46mytype-41 functor="[|]" typename="list.list(write_xml.mytype)">
- <Tag_List--write_xml-46mytype functor="List" typename="write_xml.mytype">
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
- <Int>1</Int>
- </listPart--write_xml-46listPart>
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
- <Int>2</Int>
- </listPart--write_xml-46listPart>
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <nothing--write_xml-46listPart functor="nothing" typename="write_xml.listPart" />
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
- <Int>4</Int>
- </listPart--write_xml-46listPart>
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <nothing--write_xml-46listPart functor="nothing" typename="write_xml.listPart" />
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
- <Int>6</Int>
- </listPart--write_xml-46listPart>
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
- <Int>7</Int>
- </listPart--write_xml-46listPart>
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
- <Int>8</Int>
- </listPart--write_xml-46listPart>
- <List--list-46list-40write_xml-46listPart-41 functor="[|]" typename="list.list(write_xml.listPart)">
- <nothing--write_xml-46listPart functor="nothing" typename="write_xml.listPart" />
- <Nil--list-46list-40write_xml-46listPart-41 functor="[]" typename="list.list(write_xml.listPart)" />
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </List--list-46list-40write_xml-46listPart-41>
- </Tag_List--write_xml-46mytype>
- <List--list-46list-40write_xml-46mytype-41 functor="[|]" typename="list.list(write_xml.mytype)">
- <a_map--write_xml-46mytype functor="a_map" typename="write_xml.mytype">
- <four--tree234-46tree234-40int-44-32string-41 functor="four" typename="tree234.tree234(int, string)">
- <Int>2</Int>
- <String>hello1</String>
- <Int>4</Int>
- <String>hello3</String>
- <Int>6</Int>
- <String>hello5</String>
- <two--tree234-46tree234-40int-44-32string-41 functor="two" typename="tree234.tree234(int, string)">
- <Int>1</Int>
- <String>hello</String>
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- </two--tree234-46tree234-40int-44-32string-41>
- <two--tree234-46tree234-40int-44-32string-41 functor="two" typename="tree234.tree234(int, string)">
- <Int>3</Int>
- <String>hello2</String>
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- </two--tree234-46tree234-40int-44-32string-41>
- <two--tree234-46tree234-40int-44-32string-41 functor="two" typename="tree234.tree234(int, string)">
- <Int>5</Int>
- <String>hello4</String>
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- </two--tree234-46tree234-40int-44-32string-41>
- <three--tree234-46tree234-40int-44-32string-41 functor="three" typename="tree234.tree234(int, string)">
- <Int>7</Int>
- <String>hello6</String>
- <Int>8</Int>
- <String>hello7</String>
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- <empty--tree234-46tree234-40int-44-32string-41 functor="empty" typename="tree234.tree234(int, string)" />
- </three--tree234-46tree234-40int-44-32string-41>
- </four--tree234-46tree234-40int-44-32string-41>
- </a_map--write_xml-46mytype>
- <List--list-46list-40write_xml-46mytype-41 functor="[|]" typename="list.list(write_xml.mytype)">
- <a-32-60-33-64-35-36-37-94-38-42-40-41-62-32functor-32name-33-33-33--write_xml-46mytype functor="a <!@#$%^&*()> functor name!!!" typename="write_xml.mytype">
- <Int>999</Int>
- </a-32-60-33-64-35-36-37-94-38-42-40-41-62-32functor-32name-33-33-33--write_xml-46mytype>
- <List--list-46list-40write_xml-46mytype-41 functor="[|]" typename="list.list(write_xml.mytype)">
- <a_pred--write_xml-46mytype functor="a_pred" typename="write_xml.mytype">
- <Unrecognized functor="<<predicate>>" typename="pred(int)" />
- </a_pred--write_xml-46mytype>
- <List--list-46list-40write_xml-46mytype-41 functor="[|]" typename="list.list(write_xml.mytype)">
- <t--write_xml-46mytype functor="t" typename="write_xml.mytype">
- <Unrecognized functor="tree234" typename="type_desc.type_desc">
- <Unrecognized functor="int" typename="type_desc.type_desc" />
- <Unrecognized functor="string" typename="type_desc.type_desc" />
- </Unrecognized>
- </t--write_xml-46mytype>
- <List--list-46list-40write_xml-46mytype-41 functor="[|]" typename="list.list(write_xml.mytype)">
- <ctor--write_xml-46mytype functor="ctor" typename="write_xml.mytype">
- <Unrecognized functor="tree234.tree234/2" typename="type_desc.type_ctor_desc" />
- </ctor--write_xml-46mytype>
- <List--list-46list-40write_xml-46mytype-41 functor="[|]" typename="list.list(write_xml.mytype)">
- <foreign--write_xml-46mytype functor="foreign" typename="write_xml.mytype">
- <Unrecognized functor="<<foreign>>" typename="write_xml.ftype" />
- </foreign--write_xml-46mytype>
- <List--list-46list-40write_xml-46mytype-41 functor="[|]" typename="list.list(write_xml.mytype)">
- <pointer--write_xml-46mytype functor="pointer" typename="write_xml.mytype">
- <Unrecognized functor="<<c_pointer>>" typename="c_pointer" />
- </pointer--write_xml-46mytype>
- <Nil--list-46list-40write_xml-46mytype-41 functor="[]" typename="list.list(write_xml.mytype)" />
- </List--list-46list-40write_xml-46mytype-41>
- </List--list-46list-40write_xml-46mytype-41>
- </List--list-46list-40write_xml-46mytype-41>
- </List--list-46list-40write_xml-46mytype-41>
- </List--list-46list-40write_xml-46mytype-41>
- </List--list-46list-40write_xml-46mytype-41>
- </List--list-46list-40write_xml-46mytype-41>
- </List--list-46list-40write_xml-46mytype-41>
- </List--list-46list-40write_xml-46mytype-41>
- </List--list-46list-40write_xml-46mytype-41>
- </List--list-46list-40write_xml-46mytype-41>
-</List--list-46list-40write_xml-46mytype-41>
+ <Int type="int">-123</Int>
+ <Char type="character"><</Char>
+ <Float type="float">1.12300000000000</Float>
+ <yes functor="yes" type="bool.bool" arity="0" />
+ </hello>
+ <List functor="[|]" type="list.list(write_xml.mytype)" arity="2">
+ <a_tuple functor="a_tuple" type="write_xml.mytype" arity="1">
+ <Tuple functor="{}" type="{string, int, {character, float}}" arity="3">
+ <String type="string">some more stuf</String>
+ <Int type="int">123456</Int>
+ <Tuple functor="{}" type="{character, float}" arity="2">
+ <Char type="character">a</Char>
+ <Float type="float">1.23553225220000e-97</Float>
+ </Tuple>
+ </Tuple>
+ </a_tuple>
+ <List functor="[|]" type="list.list(write_xml.mytype)" arity="2">
+ <Tag_List functor="List" type="write_xml.mytype" arity="1">
+ <List functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">1</Int>
+ </listPart>
+ <List functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">2</Int>
+ </listPart>
+ <List functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <nothing functor="nothing" type="write_xml.listPart" arity="0" />
+ <List functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">4</Int>
+ </listPart>
+ <List functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <nothing functor="nothing" type="write_xml.listPart" arity="0" />
+ <List functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">6</Int>
+ </listPart>
+ <List functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">7</Int>
+ </listPart>
+ <List functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <listPart functor="listPart" type="write_xml.listPart" arity="1">
+ <Int type="int">8</Int>
+ </listPart>
+ <List functor="[|]" type="list.list(write_xml.listPart)" arity="2">
+ <nothing functor="nothing" type="write_xml.listPart" arity="0" />
+ <Nil functor="[]" type="list.list(write_xml.listPart)" arity="0" />
+ </List>
+ </List>
+ </List>
+ </List>
+ </List>
+ </List>
+ </List>
+ </List>
+ </List>
+ </Tag_List>
+ <List functor="[|]" type="list.list(write_xml.mytype)" arity="2">
+ <a_map functor="a_map" type="write_xml.mytype" arity="1">
+ <four functor="four" type="tree234.tree234(int, string)" arity="10">
+ <Int type="int">2</Int>
+ <String type="string">hello1</String>
+ <Int type="int">4</Int>
+ <String type="string">hello3</String>
+ <Int type="int">6</Int>
+ <String type="string">hello5</String>
+ <two functor="two" type="tree234.tree234(int, string)" arity="4">
+ <Int type="int">1</Int>
+ <String type="string">hello</String>
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </two>
+ <two functor="two" type="tree234.tree234(int, string)" arity="4">
+ <Int type="int">3</Int>
+ <String type="string">hello2</String>
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </two>
+ <two functor="two" type="tree234.tree234(int, string)" arity="4">
+ <Int type="int">5</Int>
+ <String type="string">hello4</String>
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </two>
+ <three functor="three" type="tree234.tree234(int, string)" arity="7">
+ <Int type="int">7</Int>
+ <String type="string">hello6</String>
+ <Int type="int">8</Int>
+ <String type="string">hello7</String>
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ <empty functor="empty" type="tree234.tree234(int, string)" arity="0" />
+ </three>
+ </four>
+ </a_map>
+ <List functor="[|]" type="list.list(write_xml.mytype)" arity="2">
+ <a-32-60-33-64-35-36-37-94-38-42-40-41-62-32functor-32name-33-33-33 functor="a <!@#$%^&*()> functor name!!!" type="write_xml.mytype" arity="1">
+ <Int type="int">999</Int>
+ </a-32-60-33-64-35-36-37-94-38-42-40-41-62-32functor-32name-33-33-33>
+ <List functor="[|]" type="list.list(write_xml.mytype)" arity="2">
+ <a_pred functor="a_pred" type="write_xml.mytype" arity="1">
+ <Unknown functor="<<predicate>>" type="pred(int)" arity="0" />
+ </a_pred>
+ <List functor="[|]" type="list.list(write_xml.mytype)" arity="2">
+ <t functor="t" type="write_xml.mytype" arity="1">
+ <Unknown functor="tree234" type="type_desc.type_desc" arity="2">
+ <Unknown functor="int" type="type_desc.type_desc" arity="0" />
+ <Unknown functor="string" type="type_desc.type_desc" arity="0" />
+ </Unknown>
+ </t>
+ <List functor="[|]" type="list.list(write_xml.mytype)" arity="2">
+ <ctor functor="ctor" type="write_xml.mytype" arity="1">
+ <Unknown functor="tree234.tree234/2" type="type_desc.type_ctor_desc" arity="0" />
+ </ctor>
+ <List functor="[|]" type="list.list(write_xml.mytype)" arity="2">
+ <foreign functor="foreign" type="write_xml.mytype" arity="1">
+ <Unknown functor="<<foreign>>" type="write_xml.ftype" arity="0" />
+ </foreign>
+ <List functor="[|]" type="list.list(write_xml.mytype)" arity="2">
+ <pointer functor="pointer" type="write_xml.mytype" arity="1">
+ <Unknown functor="<<c_pointer>>" type="c_pointer" arity="0" />
+ </pointer>
+ <Nil functor="[]" type="list.list(write_xml.mytype)" arity="0" />
+ </List>
+ </List>
+ </List>
+ </List>
+ </List>
+ </List>
+ </List>
+ </List>
+ </List>
+ </List>
+ </List>
+</List>
+Result 5:
ok
<?xml version="1.0"?>
-<listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
- <Int>666</Int>
-</listPart--write_xml-46listPart>
+<!DOCTYPE X SYSTEM "test">
+<X>
+ <X>666</X>
+</X>
+Result 6:
ok
+Result 7:
+duplicate_elements("X", [write_xml.listPart, write_xml.wrap(write_xml.listPart)])
+
+Result 8:
multiple_functors_for_root
+
+<?xml version="1.0"?>
+<ext--1--write_xml-46ext functor="ext" type="write_xml.ext" arity="1">
+ <Int type="int">1</Int>
+</ext--1--write_xml-46ext>
+Result 9:
+ok
Index: tests/hard_coded/write_xml.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/write_xml.m,v
retrieving revision 1.1
diff -u -r1.1 write_xml.m
--- tests/hard_coded/write_xml.m 7 Dec 2004 04:55:51 -0000 1.1
+++ tests/hard_coded/write_xml.m 8 Dec 2004 10:24:45 -0000
@@ -54,7 +54,14 @@
p(_, _, _, 1).
-:- type wrap ---> wrap(mytype).
+:- type wrap(T) ---> wrap(T).
+
+:- pred p1(type_desc::in, maybe_functor_info::in, string::out,
+ list(attribute)::out) is det.
+
+p1(_, _, "X", []).
+
+:- type ext ---> some [T] ext(T).
main(!IO) :-
some [!M] (
@@ -89,23 +96,74 @@
t(type_of(!.M)),
ctor(type_ctor(type_of(!.M))),
foreign(F),
- pointer(P)]),
+ pointer(P)],
+ Map = !.M
+ ),
array.from_list(X, A),
- write_xml_doc_cc(A, with_stylesheet("text/css",
+ write_xml_doc_cc(A, unique, with_stylesheet("text/css",
"http://www.cs.mu.oz.au/a_css.css"), embed, Result1, !IO),
+ write_string("Result 1:\n", !IO),
write(Result1, !IO),
nl(!IO),
nl(!IO),
- write_xml_doc(X, no_stylesheet, external(public("test", "test.dtd")),
- Result2, !IO),
+ write_xml_doc_cc(A, unique, with_stylesheet("text/css",
+ "http://www.cs.mu.oz.au/a_css.css"), no_dtd, Result2, !IO),
+ write_string("Result 2:\n", !IO),
write(Result2, !IO),
nl(!IO),
nl(!IO),
- Simple = listPart(666),
- write_xml_doc(Simple, no_stylesheet, no_dtd, Result3, !IO),
+ write_xml_doc_cc(wrap(Map), unique, with_stylesheet("text/css",
+ "http://www.cs.mu.oz.au/a_css.css"), embed, Result3, !IO),
+ write_string("Result 3:\n", !IO),
write(Result3, !IO),
nl(!IO),
nl(!IO),
- write_xml_doc(yes, no_stylesheet, embed, Result4, !IO),
+ write_xml_doc_cc(wrap(Map), simple, with_stylesheet("text/css",
+ "http://www.cs.mu.oz.au/a_css.css"), embed, Result3_1, !IO),
+ write_string("Result 3_1:\n", !IO),
+ write(Result3_1, !IO),
+ nl(!IO),
+ nl(!IO),
+ array.from_list([listPart(1),listPart(2),
+ nothing,
+ listPart(4),
+ nothing,
+ listPart(6),
+ listPart(7),
+ listPart(8),
+ nothing], A2),
+ write_xml_doc(A2, unique, with_stylesheet("text/css",
+ "http://www.cs.mu.oz.au/a_css.css"), embed, Result4, !IO),
+ write_string("Result 4:\n", !IO),
write(Result4, !IO),
+ nl(!IO),
+ nl(!IO),
+ write_xml_doc(X, simple, no_stylesheet,
+ external(public("test", "test.dtd")), Result5, !IO),
+ write_string("Result 5:\n", !IO),
+ write(Result5, !IO),
+ nl(!IO),
+ nl(!IO),
+ Simple = listPart(666),
+ write_xml_doc(Simple, custom(p1), no_stylesheet, external(
+ system("test")), Result6, !IO),
+ write_string("Result 6:\n", !IO),
+ write(Result6, !IO),
+ nl(!IO),
+ nl(!IO),
+ write_xml_doc(wrap(Simple), custom(p1), no_stylesheet, embed,
+ Result7, !IO),
+ write_string("Result 7:\n", !IO),
+ write(Result7, !IO),
+ nl(!IO),
+ nl(!IO),
+ write_xml_doc(yes, unique, no_stylesheet, embed, Result8, !IO),
+ write_string("Result 8:\n", !IO),
+ write(Result8, !IO),
+ nl(!IO),
+ nl(!IO),
+ write_xml_doc('new ext'(1), unique, no_stylesheet, no_dtd,
+ Result9, !IO),
+ write_string("Result 9:\n", !IO),
+ write(Result9, !IO),
nl(!IO).
Index: trace/mercury_trace_browse.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_browse.c,v
retrieving revision 1.33
diff -u -r1.33 mercury_trace_browse.c
--- trace/mercury_trace_browse.c 25 Oct 2004 05:30:19 -0000 1.33
+++ trace/mercury_trace_browse.c 8 Dec 2004 14:37:06 -0000
@@ -100,6 +100,21 @@
}
void
+MR_trace_save_term_xml(const char *filename, MR_Word browser_term)
+{
+ MercuryFile mdb_out;
+ MR_String mercury_filename;
+
+ mercury_filename = (MR_String) (MR_Integer) filename;
+
+ MR_c_file_to_mercury_file(MR_mdb_out, &mdb_out);
+ MR_TRACE_CALL_MERCURY(
+ ML_BROWSE_save_term_to_file_xml(mercury_filename,
+ browser_term, &mdb_out);
+ );
+}
+
+void
MR_trace_browse(MR_Word type_info, MR_Word value, MR_Browse_Format format)
{
MercuryFile mdb_in;
Index: trace/mercury_trace_browse.h
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_browse.h,v
retrieving revision 1.17
diff -u -r1.17 mercury_trace_browse.h
--- trace/mercury_trace_browse.h 25 Oct 2004 05:30:19 -0000 1.17
+++ trace/mercury_trace_browse.h 8 Dec 2004 14:37:06 -0000
@@ -35,6 +35,8 @@
*/
extern void MR_trace_save_term(const char *filename, MR_Word browser_term);
+extern void MR_trace_save_term_xml(const char *filename,
+ MR_Word browser_term);
/*
** The following types must correspond with browse_caller_type and
Index: trace/mercury_trace_internal.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_internal.c,v
retrieving revision 1.180
diff -u -r1.180 mercury_trace_internal.c
--- trace/mercury_trace_internal.c 16 Nov 2004 00:45:14 -0000 1.180
+++ trace/mercury_trace_internal.c 8 Dec 2004 15:51:30 -0000
@@ -84,6 +84,12 @@
/* If a number has more than this many chars, the user is in trouble. */
#define MR_NUMBER_LEN 80
+/* An upper bound on the length of the xml browser temporary file name */
+#define MR_XML_TMP_FILENAME_LENGTH 1024
+
+/* An upper bound on the length of the xml browser command */
+#define MR_XML_BROWSER_COMMAND_LENGTH 4096
+
#define MDBRC_FILENAME ".mdbrc"
#define DEFAULT_MDBRC_FILENAME "mdbrc"
@@ -171,6 +177,13 @@
static MR_bool MR_print_optionals = MR_FALSE;
/*
+** These variables tell mdb how to invoke the user's xml browser.
+*/
+
+static char MR_xml_browser_command[MR_XML_BROWSER_COMMAND_LENGTH] = "";
+static char MR_xml_tmp_filename[MR_XML_TMP_FILENAME_LENGTH] = "";
+
+/*
** MR_context_position specifies whether we print context at events,
** and if so, where.
*/
@@ -517,7 +530,7 @@
const char *cat, const char *item);
static MR_bool MR_trace_options_confirmed(MR_bool *confirmed, char ***words,
int *word_count, const char *cat, const char *item);
-static MR_bool MR_trace_options_format(MR_Browse_Format *format,
+static MR_bool MR_trace_options_format(MR_Browse_Format *format, MR_bool *xml,
char ***words, int *word_count, const char *cat,
const char *item);
static MR_bool MR_trace_options_param_set(MR_Word *print_set,
@@ -540,6 +553,9 @@
static MR_bool MR_trace_options_class_decl(MR_bool *print_methods,
MR_bool *print_instances, char ***words,
int *word_count, const char *cat, const char *item);
+static MR_bool MR_trace_options_save_to_file(MR_bool *xml,
+ char ***words, int *word_count, const char *cat,
+ const char *item);
static void MR_trace_usage(const char *cat, const char *item);
static void MR_trace_do_noop(void);
@@ -630,6 +646,14 @@
MR_Browser browser, MR_Browse_Caller_Type caller,
MR_Browse_Format format);
+/* Functions to invoke the user's XML browser on terms or goals */
+static void MR_trace_save_and_invoke_xml_browser(MR_Word browser_term);
+static void MR_trace_browse_xml(MR_Word type_info, MR_Word value,
+ MR_Browse_Caller_Type caller, MR_Browse_Format format);
+static void MR_trace_browse_goal_xml(MR_ConstString name,
+ MR_Word arg_list, MR_Word is_func,
+ MR_Browse_Caller_Type caller, MR_Browse_Format format);
+
static const char *MR_trace_read_help_text(void);
static const char *MR_trace_parse_line(char *line,
char ***words, int *word_max, int *word_count);
@@ -1200,6 +1224,33 @@
}
static void
+MR_trace_save_and_invoke_xml_browser(MR_Word browser_term)
+{
+ MR_trace_save_term_xml(MR_xml_tmp_filename, browser_term);
+
+ if (system(MR_xml_browser_command) == -1) {
+ fflush(MR_mdb_out);
+ fprintf(MR_mdb_err,
+ "\nmdb: Error invoking XML browser using command:\n"
+ "\"%s\"\n", MR_xml_browser_command);
+ }
+}
+
+static void
+MR_trace_browse_xml(MR_Word type_info, MR_Word value,
+ MR_Browse_Caller_Type caller, MR_Browse_Format format)
+{
+ MR_Word browser_term;
+
+ browser_term = MR_type_value_to_browser_term((MR_TypeInfo) type_info,
+ value);
+
+ MR_trace_save_term_xml("tmp.xml", browser_term);
+
+ MR_trace_save_and_invoke_xml_browser(browser_term);
+}
+
+static void
MR_trace_browse_goal_internal(MR_ConstString name, MR_Word arg_list,
MR_Word is_func, MR_Browse_Caller_Type caller, MR_Browse_Format format)
{
@@ -1224,6 +1275,17 @@
}
}
+static void
+MR_trace_browse_goal_xml(MR_ConstString name, MR_Word arg_list,
+ MR_Word is_func, MR_Browse_Caller_Type caller, MR_Browse_Format format)
+{
+ MR_Word browser_term;
+
+ browser_term = MR_synthetic_to_browser_term(name, arg_list, is_func);
+
+ MR_trace_save_and_invoke_xml_browser(browser_term);
+}
+
static const char *
MR_trace_browse_exception(MR_Event_Info *event_info, MR_Browser browser,
MR_Browse_Caller_Type caller, MR_Browse_Format format)
@@ -1944,12 +2006,16 @@
MR_Code **jumpaddr)
{
MR_Browse_Format format;
+ MR_bool xml;
int n;
- if (! MR_trace_options_format(&format, &words, &word_count,
+ if (! MR_trace_options_format(&format, &xml, &words, &word_count,
"browsing", "print"))
{
; /* the usage message has already been printed */
+ } else if (xml) {
+ /* the --xml option is not valid for print */
+ MR_trace_usage("browsing", "print");
} else if (word_count == 1) {
const char *problem;
@@ -2016,64 +2082,76 @@
MR_Code **jumpaddr)
{
MR_Browse_Format format;
+ MR_bool xml;
int n;
+ MR_GoalBrowser goal_browser;
+ MR_Browser browser;
- if (! MR_trace_options_format(&format, &words, &word_count,
+ if (! MR_trace_options_format(&format, &xml, &words, &word_count,
"browsing", "browse"))
{
; /* the usage message has already been printed */
- } else if (word_count == 1) {
- const char *problem;
-
- problem = MR_trace_browse_one_goal(MR_mdb_out,
- MR_trace_browse_goal_internal,
- MR_BROWSE_CALLER_BROWSE, format);
-
- if (problem != NULL) {
- fflush(MR_mdb_out);
- fprintf(MR_mdb_err, "mdb: %s.\n", problem);
+ } else {
+ if (xml) {
+ goal_browser = MR_trace_browse_goal_xml;
+ browser = MR_trace_browse_xml;
+ } else {
+ goal_browser = MR_trace_browse_goal_internal;
+ browser = MR_trace_browse_internal;
}
- } else if (word_count == 2) {
- const char *problem;
+ if (word_count == 1) {
+ const char *problem;
- if (MR_streq(words[1], "goal")) {
problem = MR_trace_browse_one_goal(MR_mdb_out,
- MR_trace_browse_goal_internal,
- MR_BROWSE_CALLER_BROWSE, format);
- } else if (MR_streq(words[1], "exception")) {
- problem = MR_trace_browse_exception(event_info,
- MR_trace_browse_internal,
+ goal_browser,
MR_BROWSE_CALLER_BROWSE, format);
- } else if (MR_streq(words[1], "proc_body")) {
- problem = MR_trace_browse_proc_body(event_info,
- MR_trace_browse_internal,
- MR_BROWSE_CALLER_BROWSE, format);
- } else {
- problem = MR_trace_parse_browse_one(MR_mdb_out,
- MR_FALSE, words[1], MR_trace_browse_internal,
- MR_BROWSE_CALLER_BROWSE, format,
- MR_TRUE);
- }
- if (problem != NULL) {
- fflush(MR_mdb_out);
- fprintf(MR_mdb_err, "mdb: %s.\n", problem);
- }
- } else if (word_count == 3 && MR_streq(words[1], "action")
- && MR_trace_is_natural_number(words[2], &n))
- {
- const char *problem;
+ if (problem != NULL) {
+ fflush(MR_mdb_out);
+ fprintf(MR_mdb_err, "mdb: %s.\n", problem);
+ }
+ } else if (word_count == 2) {
+ const char *problem;
- problem = MR_trace_browse_action(MR_mdb_out, n,
- MR_trace_browse_goal_internal,
- MR_BROWSE_CALLER_BROWSE, format);
+ if (MR_streq(words[1], "goal")) {
+ problem = MR_trace_browse_one_goal(MR_mdb_out,
+ goal_browser, MR_BROWSE_CALLER_BROWSE,
+ format);
+ } else if (MR_streq(words[1], "exception")) {
+ problem = MR_trace_browse_exception(event_info,
+ browser, MR_BROWSE_CALLER_BROWSE,
+ format);
+ } else if (MR_streq(words[1], "proc_body")) {
+ problem = MR_trace_browse_proc_body(event_info,
+ browser, MR_BROWSE_CALLER_BROWSE,
+ format);
+ } else {
+ problem = MR_trace_parse_browse_one(MR_mdb_out,
+ MR_FALSE, words[1], browser,
+ MR_BROWSE_CALLER_BROWSE, format,
+ MR_TRUE);
+ }
- if (problem != NULL) {
- fflush(MR_mdb_out);
- fprintf(MR_mdb_err, "mdb: %s.\n", problem);
+ if (problem != NULL) {
+ fflush(MR_mdb_out);
+ fprintf(MR_mdb_err, "mdb: %s.\n", problem);
+ }
+ } else if (word_count == 3 && MR_streq(words[1], "action")
+ && MR_trace_is_natural_number(words[2], &n))
+ {
+ const char *problem;
+
+ problem = MR_trace_browse_action(MR_mdb_out, n,
+ goal_browser, MR_BROWSE_CALLER_BROWSE,
+ format);
+
+ if (problem != NULL) {
+ fflush(MR_mdb_out);
+ fprintf(MR_mdb_err, "mdb: %s.\n", problem);
+ }
+ } else {
+ MR_trace_usage("browsing", "browse");
}
- } else {
- MR_trace_usage("browsing", "browse");
}
return KEEP_INTERACTING;
@@ -2155,13 +2233,17 @@
MR_Word verbose_format;
MR_Word pretty_format;
- if (! MR_trace_options_param_set(&print_set, &browse_set,
+ if (word_count == 3 && MR_streq(words[1], "xml_browser_cmd")) {
+ strcpy(MR_xml_browser_command, words[2]);
+ } else if (word_count == 3 && MR_streq(words[1], "xml_tmp_filename")) {
+ strcpy(MR_xml_tmp_filename, words[2]);
+ } else if (! MR_trace_options_param_set(&print_set, &browse_set,
&print_all_set, &flat_format, &raw_pretty_format,
&verbose_format, &pretty_format, &words, &word_count,
"parameter", "set"))
{
; /* the usage message has already been printed */
- }
+ }
else if (word_count != 3 ||
! MR_trace_set_browser_param(print_set, browse_set,
print_all_set, flat_format, raw_pretty_format,
@@ -2219,8 +2301,13 @@
MR_bool verbose = MR_FALSE;
MR_Word browser_term;
const char *problem = NULL;
+ MR_bool xml = MR_FALSE;
- if (word_count != 3) {
+ if (! MR_trace_options_save_to_file(&xml, &words, &word_count,
+ "browsing", "save_to_file"))
+ {
+ ; /* the usage message has already been printed */
+ } else if (word_count != 3) {
MR_trace_usage("browsing", "save_to_file");
} else {
if (MR_streq(words[1], "goal")) {
@@ -2272,7 +2359,11 @@
fflush(MR_mdb_out);
fprintf(MR_mdb_err, "mdb: %s.\n", problem);
} else {
- MR_trace_save_term(words[2], browser_term);
+ if (xml) {
+ MR_trace_save_term_xml(words[2], browser_term);
+ } else {
+ MR_trace_save_term(words[2], browser_term);
+ }
}
}
@@ -6130,18 +6221,20 @@
{ "raw_pretty", MR_no_argument, NULL, 'r' },
{ "verbose", MR_no_argument, NULL, 'v' },
{ "pretty", MR_no_argument, NULL, 'p' },
+ { "xml", MR_no_argument, NULL, 'x' },
{ NULL, MR_no_argument, NULL, 0 }
};
static MR_bool
-MR_trace_options_format(MR_Browse_Format *format, char ***words,
+MR_trace_options_format(MR_Browse_Format *format, MR_bool *xml, char ***words,
int *word_count, const char *cat, const char *item)
{
int c;
*format = MR_BROWSE_DEFAULT_FORMAT;
+ *xml = MR_FALSE;
MR_optind = 0;
- while ((c = MR_getopt_long(*word_count, *words, "frvp",
+ while ((c = MR_getopt_long(*word_count, *words, "frvpx",
MR_trace_format_opts, NULL)) != EOF)
{
switch (c) {
@@ -6162,6 +6255,10 @@
*format = MR_BROWSE_FORMAT_PRETTY;
break;
+ case 'x':
+ *xml = MR_TRUE;
+ break;
+
default:
MR_trace_usage(cat, item);
return MR_FALSE;
@@ -6475,6 +6572,39 @@
return MR_TRUE;
}
+static struct MR_option MR_trace_save_to_file_opts[] =
+{
+ { "xml", MR_no_argument, NULL, 'x' },
+ { NULL, MR_no_argument, NULL, 0 }
+};
+
+static MR_bool
+MR_trace_options_save_to_file(MR_bool *xml,
+ char ***words, int *word_count, const char *cat, const char *item)
+{
+ int c;
+
+ MR_optind = 0;
+ while ((c = MR_getopt_long(*word_count, *words, "x",
+ MR_trace_save_to_file_opts, NULL)) != EOF)
+ {
+ switch (c) {
+
+ case 'x':
+ *xml = MR_TRUE;
+ break;
+
+ default:
+ MR_trace_usage(cat, item);
+ return MR_FALSE;
+ }
+ }
+
+ *words = *words + MR_optind - 1;
+ *word_count = *word_count - MR_optind + 1;
+ return MR_TRUE;
+}
+
static void
MR_trace_usage(const char *cat, const char *item)
/* cat is unused now, but could be used later */
@@ -7150,9 +7280,9 @@
static const char *const MR_trace_set_cmd_args[] =
{ "-A", "-B", "-P", "-f", "-p", "-v",
"--print-all", "--print", "--browse",
- "--flat", "--pretty", "--verbose",
- "format", "depth", "size", "width", "lines",
- "flat", "pretty", "verbose", NULL };
+ "--flat", "--pretty", "--verbose", "xml_tmp_filename",
+ "xml_browser_cmd", "format", "depth", "size", "width", "lines", "flat",
+ "pretty", "verbose", NULL };
static const char *const MR_trace_view_cmd_args[] =
{ "-c", "-f", "-n", "-s", "-t", "-v", "-w", "-2",
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list