[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