[m-rev.] For review: Convert Mercury terms to XML
Ian MacLarty
maclarty at cs.mu.OZ.AU
Sat Dec 4 22:02:13 AEDT 2004
For review by anyone.
Estimated hours taken: 60
Branches: main
Add library module to convert Mercury terms to XML documents and generate DTDs
for Mercury types.
extras/xml_stylesheets/mercury_term.xsl
extras/xml_stylesheets/xul_tree.xsl
Some example stylesheets. One to convert XML generate with the
to_xml library to a Mercury term and one to generate a XUL
term browser for viewing with Mozilla or Firefox.
library/library.m
Add to_xml.
library/to_xml.m
The to_xml module with predicates for generating XML for
Mercury terms and DTDs for Mercury types.
tests/hard_coded/Mmakefile
tests/hard_coded/write_xml.exp
tests/hard_coded/write_xml.m
Test to_xml predicates.
Index: extras/xml_stylesheets/mercury_term.xsl
===================================================================
RCS file: extras/xml_stylesheets/mercury_term.xsl
diff -N extras/xml_stylesheets/mercury_term.xsl
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ extras/xml_stylesheets/mercury_term.xsl 4 Dec 2004 07:03:37 -0000
@@ -0,0 +1,65 @@
+<?xml version="1.0"?>
+<xsl:stylesheet version="1.0"
+xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+xmlns="http://www.w3.org/TR/xhtml1/strict">
+<!--
+ This template produces a Mercury term from an xml document
+ generated using write_xml.write_xml_doc/3. The term is suitable for
+ reading into a Mercury program using io.read/3.
+-->
+<xsl:output method="text" indent="no" />
+<xsl:template match="text()" priority="100">
+</xsl:template>
+<xsl:template match="/" priority="200">
+ <xsl:apply-templates />
+ <xsl:text>. </xsl:text>
+</xsl:template>
+<xsl:template match="String" priority="50">
+ <xsl:text>"</xsl:text>
+ <xsl:value-of select="." disable-output-escaping="yes" />
+ <xsl:text>"</xsl:text>
+ <xsl:if test="following-sibling::*">
+ <xsl:text>,</xsl:text>
+ </xsl:if>
+</xsl:template>
+<xsl:template match="Int" priority="50">
+ <xsl:value-of select="." disable-output-escaping="yes" />
+ <xsl:if test="following-sibling::*">
+ <xsl:text>,</xsl:text>
+ </xsl:if>
+</xsl:template>
+<xsl:template match="Float" priority="50">
+ <xsl:value-of select="." disable-output-escaping="yes" />
+ <xsl:if test="following-sibling::*">
+ <xsl:text>,</xsl:text>
+ </xsl:if>
+</xsl:template>
+<xsl:template match="Char" priority="50">
+ <xsl:text>('</xsl:text>
+ <xsl:value-of select="." disable-output-escaping="yes" />
+ <xsl:text>')</xsl:text>
+ <xsl:if test="following-sibling::*">
+ <xsl:text>,</xsl:text>
+ </xsl:if>
+</xsl:template>
+<xsl:template match="*" priority="10">
+ <xsl:choose>
+ <xsl:when test="@functor">
+ <xsl:text>'</xsl:text>
+ <xsl:value-of select="@functor" disable-output-escaping="yes" />
+ <xsl:text>'</xsl:text>
+ </xsl:when>
+ <xsl:otherwise>
+ <xsl:value-of select="name()" disable-output-escaping="yes" />
+ </xsl:otherwise>
+ </xsl:choose>
+ <xsl:if test="count(child::*) != 0">
+ <xsl:text>(</xsl:text>
+ <xsl:apply-templates />
+ <xsl:text>)</xsl:text>
+ </xsl:if>
+ <xsl:if test="following-sibling::*">
+ <xsl:text>,</xsl:text>
+ </xsl:if>
+</xsl:template>
+</xsl:stylesheet>
Index: extras/xml_stylesheets/xul_tree.xsl
===================================================================
RCS file: extras/xml_stylesheets/xul_tree.xsl
diff -N extras/xml_stylesheets/xul_tree.xsl
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ extras/xml_stylesheets/xul_tree.xsl 4 Dec 2004 10:52:28 -0000
@@ -0,0 +1,279 @@
+<?xml version="1.0"?>
+<xsl:stylesheet version="1.0"
+xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
+<!--
+ This template produces a XUL term browser for a Mercury term converted
+ to XML using the to_xml library. The generated XUL can be viewed with
+ a Mozilla or Firefox browser.
+-->
+<xsl:output method="xml" indent="yes"
+ media-type="application/vnd.mozilla.xul+xml" />
+<xsl:strip-space elements="*" />
+<xsl:template match="/" priority="200">
+ <xsl:element name="window">
+ <xsl:attribute name="title">Nodes</xsl:attribute>
+ <xsl:attribute name="xmlns">http://www.mozilla.org/keymaster/gatekeeper/there.is.only.xul</xsl:attribute>
+ <xsl:element name="tree">
+ <xsl:attribute name="flex">1</xsl:attribute>
+ <xsl:attribute name="enableColumnDrag">true</xsl:attribute>
+ <xsl:element name="treecols">
+ <xsl:element name="treecol">
+ <xsl:attribute name="id">nodes</xsl:attribute>
+ <xsl:attribute name="label">Nodes</xsl:attribute>
+ <xsl:attribute name="primary">true</xsl:attribute>
+ <xsl:attribute name="flex">5</xsl:attribute>
+ </xsl:element>
+ <xsl:element name="splitter">
+ <xsl:attribute name="class">tree-splitter</xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecol">
+ <xsl:attribute name="id">field</xsl:attribute>
+ <xsl:attribute name="label">Field Name</xsl:attribute>
+ <xsl:attribute name="flex">1</xsl:attribute>
+ </xsl:element>
+ <xsl:element name="splitter">
+ <xsl:attribute name="class">tree-splitter</xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecol">
+ <xsl:attribute name="id">type</xsl:attribute>
+ <xsl:attribute name="label">Type</xsl:attribute>
+ <xsl:attribute name="flex">1</xsl:attribute>
+ </xsl:element>
+ <xsl:element name="splitter">
+ <xsl:attribute name="class">tree-splitter</xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecol">
+ <xsl:attribute name="id">depth</xsl:attribute>
+ <xsl:attribute name="label">Depth</xsl:attribute>
+ <xsl:attribute name="flex">1</xsl:attribute>
+ </xsl:element>
+ <xsl:element name="splitter">
+ <xsl:attribute name="class">tree-splitter</xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecol">
+ <xsl:attribute name="id">termpath</xsl:attribute>
+ <xsl:attribute name="label">Term Path</xsl:attribute>
+ <xsl:attribute name="flex">1</xsl:attribute>
+ </xsl:element>
+ </xsl:element>
+ <xsl:element name="treechildren">
+ <xsl:apply-templates />
+ </xsl:element>
+ </xsl:element>
+ </xsl:element>
+</xsl:template>
+<xsl:template match="String" priority="50">
+ <xsl:param name="depth">0</xsl:param>
+ <xsl:param name="termpath" />
+ <xsl:element name="treeitem">
+ <xsl:element name="treerow">
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">"<xsl:value-of select="." />"</xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="@field" />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">string</xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="$depth" />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:call-template name="showpos">
+ <xsl:with-param name="termpath"><xsl:value-of select="$termpath" /></xsl:with-param>
+ </xsl:call-template>
+ </xsl:attribute>
+ </xsl:element>
+ </xsl:element>
+ </xsl:element>
+</xsl:template>
+<xsl:template match="Int" priority="50">
+ <xsl:param name="depth">0</xsl:param>
+ <xsl:param name="termpath" />
+ <xsl:element name="treeitem">
+ <xsl:element name="treerow">
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="." />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="@field" />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">int</xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="$depth" />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:call-template name="showpos">
+ <xsl:with-param name="termpath"><xsl:value-of select="$termpath" /></xsl:with-param>
+ </xsl:call-template>
+ </xsl:attribute>
+ </xsl:element>
+ </xsl:element>
+ </xsl:element>
+</xsl:template>
+<xsl:template match="Char" priority="50">
+ <xsl:param name="depth">0</xsl:param>
+ <xsl:param name="termpath" />
+ <xsl:element name="treeitem">
+ <xsl:element name="treerow">
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="." />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="@field" />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">character</xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="$depth" />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:call-template name="showpos">
+ <xsl:with-param name="termpath"><xsl:value-of select="$termpath" /></xsl:with-param>
+ </xsl:call-template>
+ </xsl:attribute>
+ </xsl:element>
+ </xsl:element>
+ </xsl:element>
+</xsl:template>
+<xsl:template match="Float" priority="50">
+ <xsl:param name="depth">0</xsl:param>
+ <xsl:param name="termpath" />
+ <xsl:element name="treeitem">
+ <xsl:element name="treerow">
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="." />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="@field" />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">float</xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="$depth" />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:call-template name="showpos">
+ <xsl:with-param name="termpath"><xsl:value-of select="$termpath" /></xsl:with-param>
+ </xsl:call-template>
+ </xsl:attribute>
+ </xsl:element>
+ </xsl:element>
+ </xsl:element>
+</xsl:template>
+<xsl:template match="*" priority="10">
+ <xsl:param name="depth">0</xsl:param>
+ <xsl:param name="termpath" />
+ <xsl:choose>
+ <xsl:when test="parent::*[@functor='[|]'] and @functor='[|]'">
+ <xsl:if test="count(child::*) != 0">
+ <xsl:apply-templates>
+ <xsl:with-param name="depth" select="$depth+1" />
+ <xsl:with-param name="termpath">
+ <xsl:if test="ancestor::*">
+ <xsl:value-of select="concat($termpath, '/', position())"/>
+ </xsl:if>
+ </xsl:with-param>
+ </xsl:apply-templates>
+ </xsl:if>
+ </xsl:when>
+ <xsl:otherwise>
+ <xsl:element name="treeitem">
+ <xsl:if test="count(child::*) != 0">
+ <xsl:attribute name="container">true</xsl:attribute>
+ </xsl:if>
+ <xsl:element name="treerow">
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:choose>
+ <xsl:when test="@functor">
+ <xsl:value-of select="@functor" />
+ </xsl:when>
+ <xsl:otherwise>
+ <xsl:value-of select="name()" />
+ </xsl:otherwise>
+ </xsl:choose>
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="@field" />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="@typename" />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:value-of select="$depth" />
+ </xsl:attribute>
+ </xsl:element>
+ <xsl:element name="treecell">
+ <xsl:attribute name="label">
+ <xsl:call-template name="showpos">
+ <xsl:with-param name="termpath"><xsl:value-of select="$termpath" /></xsl:with-param>
+ </xsl:call-template>
+ </xsl:attribute>
+ </xsl:element>
+ </xsl:element>
+ <xsl:if test="count(child::*) != 0">
+ <xsl:element name="treechildren">
+ <xsl:apply-templates>
+ <xsl:with-param name="depth" select="$depth+1" />
+ <xsl:with-param name="termpath">
+ <xsl:if test="ancestor::*">
+ <xsl:value-of select="concat($termpath, '/', position())"/>
+ </xsl:if>
+ </xsl:with-param>
+ </xsl:apply-templates>
+ </xsl:element>
+ </xsl:if>
+ </xsl:element>
+ </xsl:otherwise>
+ </xsl:choose>
+</xsl:template>
+<xsl:template name="showpos">
+ <xsl:param name="termpath" />
+ <xsl:choose>
+ <xsl:when test="ancestor::*">
+ <xsl:value-of select="concat($termpath, '/', position())"/>
+ </xsl:when>
+ <xsl:otherwise>
+ <xsl:value-of select="'/'" />
+ </xsl:otherwise>
+ </xsl:choose>
+</xsl:template>
+</xsl:stylesheet>
Index: library/library.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/library.m,v
retrieving revision 1.75
diff -u -r1.75 library.m
--- library/library.m 16 Nov 2004 00:45:12 -0000 1.75
+++ library/library.m 3 Dec 2004 02:51:13 -0000
@@ -108,6 +108,7 @@
:- import_module version_hash_table.
:- import_module version_store.
:- import_module version_types.
+:- import_module to_xml.
% The modules intended for Mercury system implementors.
:- import_module private_builtin.
@@ -226,6 +227,7 @@
mercury_std_library_module("version_hash_table").
mercury_std_library_module("version_store").
mercury_std_library_module("version_types").
+mercury_std_library_module("to_xml").
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
Index: library/to_xml.m
===================================================================
RCS file: library/to_xml.m
diff -N library/to_xml.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ library/to_xml.m 4 Dec 2004 10:46:28 -0000
@@ -0,0 +1,1046 @@
+%-----------------------------------------------------------------------------r
+% Copyright (C) 1993-2004 The University of Melbourne.
+% This file may only be copied under the terms of the GNU Library General
+% Public License - see the file COPYING.LIB in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: xml_out.m.
+% Main author: maclarty.
+% Stability: low.
+%
+% A Mercury term to XML converter.
+%
+% This module contains predicates to write arbitrary Mercury terms to
+% an output stream as XML.
+%
+% Each functor in a term is given a corresponding well-formed element name
+% in the XML document.
+%
+% 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:
+%
+% 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.
+%
+% field - discriminated union functor arguments (including those with a
+% builtin type) that have a field name will have this attribute set.
+%
+% The XML document can also be annotated with a style sheet 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
+% this library back to Mercury terms that can be read with io.read/3. There is
+% also a stylesheet in extras to browse a Mercury term with Mozilla using XUL.
+%
+% 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.
+%
+% The generated DTD is also a good reference when creating a stylesheet as
+% it contains comments describing the mapping from functors to elements.
+%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- module to_xml.
+:- interface.
+
+:- import_module io, int, deconstruct, std_util.
+
+%-----------------------------------------------------------------------------%
+
+:- type maybe_stylesheet
+ ---> with_stylesheet(string, string) % stylesheet type and href.
+ ; no_stylesheet.
+
+ % Values of this type specifys the DOCTYPE of an XML document when
+ % the DOCTYPE is defined by an external DTD.
+ %
+:- type doctype
+ ---> public(string) % FPI
+ ; public(string, string) % FPI, URL
+ ; system(string). % URL
+
+ % Values of this type specify whether a DTD should be included in
+ % a generated XML document and if so how.
+ %
+:- type maybe_dtd
+ % Embed the entire DTD in the document.
+ ---> embed
+ % Included a reference to an external DTD.
+ ; external(doctype)
+ % Do not include any DOCTYPE information.
+ ; no_dtd.
+
+ % 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.
+ %
+:- 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.
+ % 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 multiplt_functors_for_root
+ % will be returned in DTDResult and nothing will be written.
+ %
+:- pred write_xml_doc(T::in, 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
+ % output stream.
+ %
+:- pred write_xml_doc(io.output_stream::in, T::in, 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.
+ % 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
+ % multiplt_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
+ % output stream.
+ %
+:- pred write_xml_doc_cc(io.output_stream::in, T::in, maybe_stylesheet::in,
+ maybe_dtd::in, dtd_generation_result::out, io::di, io::uo) is cc_multi.
+
+ % True if the given type doesn't 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.
+ %
+:- pred write_dtd(T::unused, 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.
+ %
+:- pred write_dtd(io.output_stream::in, T::unused, 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.
+ %
+:- pred write_dtd_from_type(type_desc::in, 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.
+ %
+:- pred write_dtd_from_type(io.output_stream::in, type_desc::in,
+ dtd_generation_result::out, io::di, io::uo) is det.
+
+ % write_xml_element(NonCanon, IndentLevel, Term, !IO).
+ % Write XML elements for the given term and all it's descendents,
+ % using IndentLevel as the initial indentation level (each
+ % indentation level is one space character). No <?xml ... ?>
+ % header will be written. Non canonical terms will be handled
+ % according to the value of NonCanon. See the deconstruct
+ % 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.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module string, list, char, exception, bool, array.
+:- import_module exception, map.
+
+%-----------------------------------------------------------------------------%
+
+write_xml_doc(X, MaybeStyleSheet, MaybeDTD, DTDResult, !IO) :-
+ (
+ ( MaybeDTD \= embed ; ok_to_generate_dtd(type_of(X)) )
+ ->
+ DTDResult = ok,
+ write_xml_header(no, !IO),
+ write_stylesheet_ref(MaybeStyleSheet, !IO),
+ write_doctype(canonicalize, X, MaybeDTD, _, !IO),
+ write_xml_element(canonicalize, 0, X, !IO)
+ ;
+ DTDResult = multiple_functors_for_root
+ ).
+
+write_xml_doc(Stream, X, MaybeStyleSheet, MaybeDTD, DTDResult, !IO) :-
+ io.set_output_stream(Stream, OrigStream, !IO),
+ write_xml_doc(X, MaybeStyleSheet, MaybeDTD, DTDResult, !IO),
+ io.set_output_stream(OrigStream, _, !IO).
+
+write_xml_doc_cc(X, MaybeStyleSheet, MaybeDTD, DTDResult, !IO) :-
+ (
+ ( MaybeDTD = embed ; ok_to_generate_dtd(type_of(X)) )
+ ->
+ DTDResult = ok,
+ 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)
+ ;
+ DTDResult = multiple_functors_for_root
+ ).
+
+write_xml_doc_cc(Stream, X, MaybeStyleSheet, MaybeDTD, DTDResult, !IO) :-
+ io.set_output_stream(Stream, OrigStream, !IO),
+ write_xml_doc_cc(X, MaybeStyleSheet, MaybeDTD, DTDResult, !IO),
+ io.set_output_stream(OrigStream, _, !IO).
+
+write_xml_element(NonCanon, IndentLevel, X, !IO) :-
+ type_to_univ(X, Univ),
+ write_xml_element_univ(NonCanon, IndentLevel, Univ, [], _, !IO).
+
+write_dtd(Term, DTDResult, !IO) :-
+ type_of(Term) = TypeDesc,
+ write_dtd_from_type(TypeDesc, DTDResult, !IO).
+
+write_dtd(Stream, Term, DTDResult, !IO) :-
+ io.set_output_stream(Stream, OrigStream, !IO),
+ write_dtd(Term, DTDResult, !IO),
+ io.set_output_stream(OrigStream, _, !IO).
+
+write_dtd_from_type(Stream, TypeDesc, DTDResult, !IO) :-
+ io.set_output_stream(Stream, OrigStream, !IO),
+ write_dtd_from_type(TypeDesc, DTDResult, !IO),
+ io.set_output_stream(OrigStream, _, !IO).
+
+:- pred write_xml_header(maybe(string)::in, io::di, io::uo) is det.
+
+write_xml_header(MaybeEncoding, !IO) :-
+ io.write_string("<?xml version=""1.0""", !IO),
+ (
+ MaybeEncoding = yes(Encoding),
+ io.write_string(" encoding=""", !IO),
+ io.write_string(Encoding, !IO),
+ io.write_string("""?>\n", !IO)
+ ;
+ MaybeEncoding = no,
+ io.write_string("?>\n", !IO)
+ ).
+
+:- pred write_stylesheet_ref(maybe_stylesheet::in, io::di, io::uo) is det.
+
+write_stylesheet_ref(no_stylesheet, !IO).
+write_stylesheet_ref(with_stylesheet(Type, Href), !IO) :-
+ io.write_string("<?xml-stylesheet type=""", !IO),
+ io.write_string(Type, !IO),
+ io.write_string(""" href=""", !IO),
+ 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),
+ 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)),
+ io.write_string("<!DOCTYPE ", !IO),
+ io.write_string(Root, !IO),
+ (
+ DocType = public(PUBLIC),
+ io.write_string(" PUBLIC """, !IO),
+ io.write_string(PUBLIC, !IO)
+ ;
+ DocType = public(PUBLIC, SYSTEM),
+ io.write_string(" PUBLIC """, !IO),
+ io.write_string(PUBLIC, !IO),
+ io.write_string(""" """, !IO),
+ io.write_string(SYSTEM, !IO)
+ ;
+ DocType = system(SYSTEM),
+ io.write_string(" SYSTEM """, !IO),
+ io.write_string(SYSTEM, !IO)
+ ),
+ io.write_string(""">\n", !IO).
+
+%-----------------------------------------------------------------------------%
+%
+% Some reserved element names. Reserved element names all start with a
+% capital letter so as not to conflict with a mangled element name.
+%
+
+:- func reserved_prefix = string.
+
+ % A prefix for functors that start with a capital letter or
+ % a non-letter.
+ %
+reserved_prefix = "Tag_".
+
+:- pred common_mercury_functor(string, string).
+:- mode common_mercury_functor(in, out) is semidet.
+:- mode common_mercury_functor(out, in) is semidet.
+
+ % These should all start with a capital letter so as not to
+ % conflict with a mangled name.
+ %
+common_mercury_functor("[|]", "List").
+common_mercury_functor("[]", "Nil").
+common_mercury_functor("{}", "Tuple").
+
+ % A general element for types whos structure we do not generate
+ % DTD rules for.
+ %
+:- func unrecognized_element = string.
+
+unrecognized_element = "Unrecognized".
+
+:- func array_element = string.
+
+array_element = "Array".
+
+:- pred is_primitive_type(type_desc::in, string::out) is semidet.
+
+is_primitive_type(TypeDesc, Element) :-
+ (
+ type_of("") = TypeDesc
+ ->
+ Element = "String"
+ ;
+ type_of('c') = TypeDesc
+ ->
+ Element = "Char"
+ ;
+ type_of(1) = TypeDesc
+ ->
+ Element = "Int"
+ ;
+ type_of(1.0) = TypeDesc,
+ Element = "Float"
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Mangling functions.
+%
+% We use the following mangling scheme to create well formed element names
+% that do not begin with a capital letter (capitals are used for reserved
+% elements).
+%
+% If the string to be mangled begins with a capital letter then we prefix it
+% with another string reserved for this purpose. Then we replace all
+% characters which aren't alpha numeric or underscores with '-' followed by
+% the character code.
+%
+
+:- func mangle(string) = string.
+
+mangle(Functor) = Element :-
+ string.split(Functor, 1, Head, Tail),
+ (
+ string.is_alpha(Head),
+ string.to_lower(Head) = Head
+ ->
+ First = Head,
+ Rest = Tail
+ ;
+ First = reserved_prefix,
+ Rest = Head ++ Tail
+ ),
+ string.foldl(mangle_char, Rest, [], ElementChrs),
+ Element = First ++ string.from_char_list(ElementChrs).
+
+:- pred mangle_char(char::in, list(char)::in, list(char)::out)
+ is det.
+
+ % XXX This is system dependent since char.to_int is system dependent.
+ %
+mangle_char(Chr, PrevChrs, list.append(PrevChrs, Chrs)) :-
+ (
+ char.is_alnum_or_underscore(Chr)
+ ->
+ Chrs = [Chr]
+ ;
+ Chrs = ['-' | string.to_char_list(string.int_to_string(
+ char.to_int(Chr)))]
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- type element_request
+ ---> from_functor_name(string)
+ ; from_functor_num(int).
+
+:- 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.
+
+get_elements_and_args(TypeDesc, Elements, Functors, MaybeArgTypeLists) :-
+ NumFunctors = num_functors(TypeDesc),
+ (
+ NumFunctors > 0
+ ->
+ 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 = Functors0,
+ MaybeArgTypeLists = MaybeArgTypeLists0
+ ;
+ throw(write_xml_internal_error("get_elements_and_args",
+ "get_functor failed for discriminated union"))
+ )
+ ;
+ Elements = [get_element(TypeDesc, from_functor_num(0))],
+ (
+ 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]
+ ;
+ MaybeArgTypeLists = [[]],
+ % We make these the same so the "functor" attribute
+ % isn't fixed.
+ Functors = Elements
+ )
+ ).
+
+:- pred primitive_value(univ::in, string::out) is semidet.
+
+primitive_value(Univ, PrimValue) :-
+ (
+ univ_to_type(Univ, String)
+ ->
+ PrimValue = String`with_type`string
+ ;
+ univ_to_type(Univ, Char)
+ ->
+ PrimValue = char_to_string(Char)
+ ;
+ univ_to_type(Univ, Int)
+ ->
+ PrimValue = int_to_string(Int)
+ ;
+ univ_to_type(Univ, Float),
+ PrimValue = float_to_string(Float)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- 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.
+
+ % 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.
+ %
+write_xml_element_univ(NonCanon, IndentLevel, Univ,
+ MaybeFieldNames, RemainingMaybeFieldNames, !IO) :-
+ (
+ MaybeFieldNames = [MaybeFieldName | RemainingMaybeFieldNames]
+ ;
+ MaybeFieldNames = [],
+ RemainingMaybeFieldNames = [],
+ MaybeFieldName = no
+ ),
+ deconstruct.deconstruct(Term, NonCanon, Functor, Arity, Args),
+ Term = univ_value(Univ),
+ TypeDesc = type_of(Term),
+ Element = get_element(TypeDesc, from_functor_name(Functor)),
+ (
+ primitive_value(Univ, PrimValue)
+ ->
+ indent(IndentLevel, !IO),
+ write_primitive_element(Element, PrimValue, MaybeFieldName,
+ !IO)
+ ;
+ (
+ Args = [],
+ indent(IndentLevel, !IO),
+ write_empty_element(Element, Functor, MaybeFieldName,
+ TypeDesc, !IO)
+ ;
+ Args = [_ | _],
+ get_field_names(TypeDesc, Functor, Arity,
+ ChildMaybeFieldNames),
+ indent(IndentLevel, !IO),
+ write_element_start(Element, Functor, MaybeFieldName,
+ TypeDesc, !IO),
+ write_child_xml_elements(NonCanon, IndentLevel + 1,
+ Args, ChildMaybeFieldNames, !IO),
+ indent(IndentLevel, !IO),
+ write_element_end(Element, !IO)
+ )
+ ).
+
+:- pred is_discriminated_union(type_desc::in, int::out) is semidet.
+
+is_discriminated_union(TypeDesc, NumFunctors) :-
+ NumFunctors = num_functors(TypeDesc),
+ NumFunctors > -1.
+
+:- pred is_array(type_desc::in, type_desc::out) is semidet.
+
+is_array(TypeDesc, ArgType) :-
+ type_ctor_and_args(TypeDesc, TypeCtor, ArgTypes),
+ ArgTypes = [ArgType],
+ type_ctor_name(TypeCtor) = "array",
+ type_ctor_module_name(TypeCtor) = "array".
+
+:- pragma memo(get_field_names/4).
+
+:- pred get_field_names(type_desc::in, string::in, int::in,
+ list(maybe(string))::out) is det.
+
+get_field_names(TypeDesc, Functor, Arity, MaybeFields) :-
+ NumFunctors = num_functors(TypeDesc),
+ (
+ NumFunctors > 0
+ ->
+ FunctorNums = 0`..`(NumFunctors - 1),
+ (
+ find_field_names(TypeDesc, FunctorNums, Functor,
+ Arity, FoundMaybeFields)
+ ->
+ MaybeFields = FoundMaybeFields
+ ;
+ MaybeFields = []
+ )
+ ;
+ MaybeFields = []
+ ).
+
+:- pred find_field_names(type_desc::in, list(int)::in, string::in, int::in,
+ list(maybe(string))::out) is semidet.
+
+find_field_names(TypeDesc, [FunctorNum | FunctorNums], Functor, Arity,
+ MaybeFieldNames) :-
+ (
+ get_functor(TypeDesc, FunctorNum, Functor, Arity, _,
+ FoundFieldNames)
+ ->
+ MaybeFieldNames = FoundFieldNames
+ ;
+ find_field_names(TypeDesc, FunctorNums, Functor, Arity,
+ MaybeFieldNames)
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% The following is done to get around an unimplemented feature where higher
+% order terms with more than one mode can't be passed around (so we can't just
+% pass write_xml_element_univ to foldl).
+%
+
+:- 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.
+
+write_child_xml_elements(NonCanon, IndentLevel, Args,
+ MaybeFieldNames, !IO) :-
+ (
+ NonCanon = do_not_allow,
+ list.foldl2(
+ write_xml_element_univ_do_not_allow(
+ IndentLevel), Args,
+ MaybeFieldNames, _, !IO)
+ ;
+ NonCanon = canonicalize,
+ list.foldl2(
+ write_xml_element_univ_canonicalize(
+ IndentLevel), Args,
+ MaybeFieldNames, _, !IO)
+ ;
+ NonCanon = include_details_cc,
+ list.foldl2(
+ write_xml_element_univ_include_details_cc(
+ IndentLevel), Args,
+ MaybeFieldNames, _, !IO)
+ ).
+
+:- pred write_xml_element_univ_do_not_allow( int, univ,
+ list(maybe(string)), list(maybe(string)), io, io).
+:- mode write_xml_element_univ_do_not_allow(in, in, in, out, di, uo)
+ is det.
+
+write_xml_element_univ_do_not_allow(IndentLevel, Univ,
+ MaybeFieldNames0, MaybeFieldNames, !IO) :-
+ write_xml_element_univ(do_not_allow, IndentLevel,
+ Univ, MaybeFieldNames0, MaybeFieldNames, !IO).
+
+:- pred write_xml_element_univ_canonicalize( int, univ,
+ list(maybe(string)), list(maybe(string)), io, io).
+:- mode write_xml_element_univ_canonicalize(in, in, in, out, di, uo)
+ is det.
+
+write_xml_element_univ_canonicalize(IndentLevel, Univ,
+ MaybeFieldNames0, MaybeFieldNames, !IO) :-
+ write_xml_element_univ(canonicalize, IndentLevel,
+ Univ, MaybeFieldNames0, MaybeFieldNames, !IO).
+
+:- pred write_xml_element_univ_include_details_cc(int, univ,
+ list(maybe(string)), list(maybe(string)), io, io).
+:- mode write_xml_element_univ_include_details_cc(in, in, in, out, di, uo)
+ is cc_multi.
+
+write_xml_element_univ_include_details_cc(IndentLevel, Univ,
+ MaybeFieldNames0, MaybeFieldNames, !IO) :-
+ write_xml_element_univ(include_details_cc,
+ IndentLevel, Univ, MaybeFieldNames0, MaybeFieldNames, !IO).
+
+%-----------------------------------------------------------------------------%
+%
+% Predicates for writing elements
+%
+
+:- pred indent(int::in, io::di, io::uo) is det.
+
+indent(IndentLevel, !IO) :-
+ (
+ IndentLevel > 0
+ ->
+ io.write_char('\t', !IO),
+ indent(IndentLevel - 1, !IO)
+ ;
+ true
+ ).
+
+:- pred write_primitive_element(string::in, string::in,
+ maybe(string)::in, io::di, io::uo) is det.
+
+write_primitive_element(Element, Value, MaybeFieldName, !IO) :-
+ io.write_string("<", !IO),
+ io.write_string(Element, !IO),
+ write_field_name_attribute(MaybeFieldName, !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.
+
+write_element_start(Element, Functor, 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),
+ 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.
+
+write_empty_element(Element, Functor, 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),
+ io.write_string(" />\n", !IO).
+
+:- pred write_field_name_attribute(maybe(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).
+
+:- pred write_type_name_attribute(type_desc::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).
+
+:- pred write_functor_attribute(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).
+
+:- pred write_element_end(string::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).
+
+:- pred xml_predefined_entity(char::in, string::out) is semidet.
+
+xml_predefined_entity(('<'), "<").
+xml_predefined_entity(('>'), ">").
+xml_predefined_entity(('&'), "&").
+xml_predefined_entity(('\''), "'").
+xml_predefined_entity(('\"'), """).
+
+%-----------------------------------------------------------------------------%
+%
+% Predicates to write the DTD for a type.
+%
+
+write_dtd_from_type(TypeDesc, DTDResult, !IO) :-
+ (
+ get_elements_and_args(TypeDesc, [RootElement], [_],
+ [ArgTypes])
+ ->
+ 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),
+ (
+ Unrecognised = []
+ ;
+ 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
+ ;
+ DTDResult = multiple_functors_for_root
+ ).
+
+ok_to_generate_dtd(TypeDesc) :-
+ get_elements_and_args(TypeDesc, [_], [_], [_]).
+
+:- pred write_primitive_dtd_element(string::in, io::di, io::uo)
+ is det.
+
+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).
+
+ % 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 1st 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) :-
+ (
+ map.search(AlreadyDone, TypeDesc, _)
+ ->
+ write_dtd_types(TypeDescs, AlreadyDone, Unrecognised0,
+ Unrecognised, !IO)
+ ;
+ write_dtd_type_elements(TypeDesc, ChildArgTypes,
+ IsUnrecognised, !IO),
+ (
+ IsUnrecognised = yes
+ ->
+ list.merge([TypeDesc], Unrecognised0, NewUnrecognised)
+ ;
+ NewUnrecognised = Unrecognised0
+ ),
+ map.set(AlreadyDone, TypeDesc, unit, NewAlreadyDone),
+ write_dtd_types(append(ChildArgTypes, TypeDescs),
+ NewAlreadyDone, NewUnrecognised, Unrecognised, !IO)
+ ).
+
+:- pred write_unrecognised_dtd_element(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).
+
+:- pred write_dtd_field_attlist(string::in, io::di, io::uo) is det.
+
+write_dtd_field_attlist(Element, !IO) :-
+ io.write_string("<!ATTLIST ", !IO),
+ io.write_string(Element, !IO),
+ io.write_string(" field CDATA #IMPLIED>\n", !IO).
+
+:- pred write_dtd_type_attlist(string::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).
+
+:- pred write_dtd_type_elements(type_desc::in, list(type_desc)::out, bool::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),
+ 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 write_xml_internal_error
+ ---> write_xml_internal_error(string, string).
+
+:- pred write_dtd_entries(type_desc::in,
+ list(string)::in, list(string)::in, list(list(type_desc))::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) :-
+ io.write_string("<!ELEMENT ", !IO),
+ io.write_string(Element, !IO),
+ io.write_string(" ", !IO),
+ (
+ ArgTypeList = [],
+ io.write_string("EMPTY>\n", !IO)
+ ;
+ ArgTypeList = [Head | Tail],
+ (
+ Tail = [_ | _],
+ Braces = yes
+ ;
+ 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, !IO),
+
+ ( Braces = yes, io.write_string(")", !IO) ; Braces = no ),
+
+ ( is_array(TypeDesc, _) -> io.write_string("*)", !IO) ; true ),
+
+ 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(write_xml_internal_error("write_dtd_cons_elements",
+ "lists not of equal length")).
+write_dtd_entries(_, [], [_ | _], [], !IO) :-
+ throw(write_xml_internal_error("write_dtd_cons_elements",
+ "lists not of equal length")).
+write_dtd_entries(_, [_ | _], [_ | _], [], !IO) :-
+ throw(write_xml_internal_error("write_dtd_cons_elements",
+ "lists not of equal length")).
+write_dtd_entries(_, [], [], [_ | _], !IO) :-
+ throw(write_xml_internal_error("write_dtd_cons_elements",
+ "lists not of equal length")).
+write_dtd_entries(_, [_ | _], [], [_ | _], !IO) :-
+ throw(write_xml_internal_error("write_dtd_cons_elements",
+ "lists not of equal length")).
+write_dtd_entries(_, [], [_ | _], [_ | _], !IO) :-
+ throw(write_xml_internal_error("write_dtd_cons_elements",
+ "lists not of equal length")).
+
+ % 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.
+
+write_dtd_allowed_functors_regex(TypeDesc, !IO) :-
+ get_elements_and_args(TypeDesc, Elements, _, _),
+ (
+ length(Elements) > 1
+ ->
+ io.write_string("(", !IO),
+ io.write_list(Elements, "|", io.write_string, !IO),
+ io.write_string(")", !IO)
+ ;
+ io.write_list(Elements, "|", io.write_string, !IO)
+ ).
+
+%-----------------------------------------------------------------------------%
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.242
diff -u -r1.242 Mmakefile
--- tests/hard_coded/Mmakefile 2 Dec 2004 08:03:57 -0000 1.242
+++ tests/hard_coded/Mmakefile 3 Dec 2004 04:17:28 -0000
@@ -188,7 +188,8 @@
version_array_test \
write \
write_reg1 \
- write_reg2
+ write_reg2 \
+ write_xml
# JAVA_PASS_PROGS lists those tests which will succeed in grade Java.
Index: tests/hard_coded/write_xml.exp
===================================================================
RCS file: tests/hard_coded/write_xml.exp
diff -N tests/hard_coded/write_xml.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/write_xml.exp 4 Dec 2004 10:45:12 -0000
@@ -0,0 +1,470 @@
+<?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 [
+
+<!-- Builtin Mercury types -->
+
+<!ELEMENT String (#PCDATA)>
+<!ATTLIST String field CDATA #IMPLIED>
+<!ELEMENT Char (#PCDATA)>
+<!ATTLIST Char field CDATA #IMPLIED>
+<!ELEMENT Int (#PCDATA)>
+<!ATTLIST Int field CDATA #IMPLIED>
+<!ELEMENT Float (#PCDATA)>
+<!ATTLIST Float field CDATA #IMPLIED>
+
+<!-- Elements for functors of type "array.array(write_xml.mytype)" -->
+
+<!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 "[|]">
+
+<!-- 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">
+
+<!-- Elements for functors of type "tree234.tree234(int, string)" -->
+
+<!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>
+
+]>
+<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>
+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
+
+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>
+ok
+
+<?xml version="1.0"?>
+<listPart--write_xml-46listPart functor="listPart" typename="write_xml.listPart">
+ <Int>666</Int>
+</listPart--write_xml-46listPart>
+ok
+
+multiple_functors_for_root
Index: tests/hard_coded/write_xml.m
===================================================================
RCS file: tests/hard_coded/write_xml.m
diff -N tests/hard_coded/write_xml.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/write_xml.m 4 Dec 2004 10:34:37 -0000
@@ -0,0 +1,111 @@
+:- module write_xml.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is cc_multi.
+
+:- implementation.
+
+:- import_module to_xml, bool, list, float, string, int, char, array, map.
+:- import_module std_util.
+
+:- type mytype
+ ---> hello(field1::string, 'Field<2>'::int, char,
+ 'another field'::float, bool)
+ ; 'List'(list(listPart))
+ ; 'Tag-'(int)
+ ; 'String'(string)
+ ; a_tuple({string, int, {char, float}})
+ ; a_map(map(int, string))
+ ; a_pred(pred(int))
+ ; 'a <!@#$%^&*()> functor name!!!'(int)
+ ; t(type_desc)
+ ; ctor(type_ctor_desc)
+ ; pointer(c_pointer)
+ ; foreign(ftype).
+
+:- type listPart ---> listPart(int) ; nothing.
+
+:- type a == array(mytype).
+
+:- type ftype.
+
+:- pred make_ftype(ftype::out) is det.
+
+:- pragma foreign_type("C", ftype, "int").
+
+:- pragma foreign_proc("C", make_ftype(F::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ F = 1;
+").
+
+:- pred make_pointer(c_pointer::out) is det.
+
+:- pragma foreign_proc("C", make_pointer(P::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ P = (MR_Word) NULL;
+").
+
+:- pred p(int::in, int::in, mytype::in, int::out) is det.
+
+p(_, _, _, 1).
+
+:- type wrap ---> wrap(mytype).
+
+main(!IO) :-
+ some [!M] (
+ map.init(!:M),
+ map.set(!.M, 1, "hello", !:M),
+ map.set(!.M, 2, "hello1", !:M),
+ map.set(!.M, 3, "hello2", !:M),
+ map.set(!.M, 4, "hello3", !:M),
+ map.set(!.M, 5, "hello4", !:M),
+ map.set(!.M, 6, "hello5", !:M),
+ map.set(!.M, 7, "hello6", !:M),
+ map.set(!.M, 8, "hello7", !:M),
+ make_ftype(F),
+ make_pointer(P),
+ X = [
+ 'Tag-'(44),
+ 'String'("a string"),
+ hello("this \n\nis a <string>&", -123, '<', 1.123, yes),
+ a_tuple({"some more stuf", 123456,
+ {a, 123.55322522e-99}}),
+ 'List'([listPart(1),
+ listPart(2),
+ nothing,
+ listPart(4),
+ nothing,
+ listPart(6),
+ listPart(7),
+ listPart(8),
+ nothing]),
+ a_map(!.M), 'a <!@#$%^&*()> functor name!!!'(999),
+ a_pred(p(1, 2, hello("a string", 1, 'c', -0.00001e-10, yes))),
+ t(type_of(!.M)),
+ ctor(type_ctor(type_of(!.M))),
+ foreign(F),
+ pointer(P)]),
+ array.from_list(X, A),
+ write_xml_doc_cc(A, with_stylesheet("text/css",
+ "http://www.cs.mu.oz.au/a_css.css"), embed, Result1, !IO),
+ write(Result1, !IO),
+ nl(!IO),
+ nl(!IO),
+ write_xml_doc(X, no_stylesheet, external(public("test", "test.dtd")),
+ Result2, !IO),
+ write(Result2, !IO),
+ nl(!IO),
+ nl(!IO),
+ Simple = listPart(666),
+ write_xml_doc(Simple, no_stylesheet, no_dtd, Result3, !IO),
+ write(Result3, !IO),
+ nl(!IO),
+ nl(!IO),
+ write_xml_doc(yes, no_stylesheet, embed, Result4, !IO),
+ write(Result4, !IO),
+ nl(!IO).
--------------------------------------------------------------------------
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