mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-16 14:25:56 +00:00
Code Issues Projects Releases Wiki Activity
Files
41e75fcc78e8a2d7fa88efb34ca76ae4ebb1f3a9
mercury/library/term_to_xml.m
Julien Fischer 47fec100be Further library consistency improvements. 
Branches: main

Further library consistency improvements.

library.term.m:
	Change the argument ordering of the predicate create_var/3.
	(This breaks backwards compatibility but that should be okay
	as most code uses the varset module rather than calling this
	directly.)

	Fix the layout in a spot.

library/string.m:
library/type_desc.m:
	Change predicates and functions that use a "_det" suffix in
	their name to use a "det_" prefix as in the rest of the library
	modules.  Deprecate the suffix versions.

library/varset.m:
	Delete a reference to the graph module.

NEWS:
	Announce the above changes.

library/construct.m:
library/varset.m:
library/term_to_xml.m:
compiler/passes_aux.m:
tests/hard_coded/construct_test.m:
tests/hard_coded/deep_copy.m:
tests/hard_coded/write.m:
tests/hard_coded/write_binary.m:
tests/hard_coded/write_reg1.m:
	Conform to the above changes.
2011-05-25 02:02:53 +00:00

1644 lines
62 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1993-2007, 2010-2011 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: term_to_xml.m.
% Main author: maclarty.
% Stability: low.
%
% This module provides two mechanisms for converting Mercury terms
% to XML documents.
%
% Method 1
% --------
% The first method requires a type to be an instance of the xmlable typeclass
% before values of the type can be written as XML.
% Members of the xmlable typeclass must implement a to_xml method which
% maps values of the type to XML elements.
% The XML elements may contain arbitrary children, comments and data.
%
% Method 2
% --------
% The second method is less flexible than the first, but it allows for the
% automatic generation of a DTD.
% Each functor in a term is given a corresponding well-formed element name in
% the XML document according to a mapping. Some predefined mappings are
% provided, but user defined mappings may also be used.
%
% Method 1 vs. Method 2
% ---------------------
%
% Method 1 allows values of a specific type to be mapped to arbitrary XML
% elements with arbitrary children and arbitrary attributes.
% In method 2 each functor in a term can be mapped to only one XML element.
% Method 2 also only allows a selected set of attributes.
% In method 2 a DTD can be automatically generated. In method 1 DTDs cannot
% be automatically generated.
%
% Method 1 is useful for mapping a specific type to XML,
% for example mapping terms which represent mathematical expressions to
% MathML.
% Method 2 is useful for mapping arbitrary terms of any type to XML.
%
% In both methods the XML document can be annotated with a stylesheet
% reference.
%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- module term_to_xml.
:- interface.
:- import_module deconstruct.
:- import_module list.
:- import_module maybe.
:- import_module stream.
:- import_module type_desc.
%-----------------------------------------------------------------------------%
%
% Method 1 interface
%
% Instances of this typeclass can be converted to XML.
%
:- typeclass xmlable(T) where [
func to_xml(T::in) = (xml::out(xml_doc)) is det
].
% Values of this type represent an XML document or a portion of
% an XML document.
%
:- type xml
---> elem(
% An XML element with a name, list of attributes
% and a list of children.
element_name :: string,
attributes :: list(attr),
children :: list(xml)
)
; data(string)
% Textual data. `<', `>', `&', `'' and `"' characters
% will be replaced by `&lt;', `&gt;', `&amp;', `&apos;'
% and `&quot;' respectively.
; cdata(string)
% Data to be enclosed in `<![CDATA[' and `]]>' tags.
% The string may not contain the substring "]]>".
% If it does then invalid XML will be generated.
; comment(string)
% An XML comment. The comment should not
% include the `<!--' and `-->'. Any occurrences of
% the substring "--" will be replaced by " - ",
% since "--" is not allowed in XML comments.
; entity(string)
% An entity reference. The string will
% have `&' prepended and `;' appended before being
% output.
; raw(string).
% Raw XML data. The data will be written out verbatim.
% An XML document must have an element at the top-level.
% The following inst is used to enforce this restriction.
%
:- inst xml_doc
---> elem(
ground, % element_name
ground, % attributes
ground % children
).
% An element attribute, mapping a name to a value.
%
:- type attr
---> attr(string, string).
% Values of this type specify the DOCTYPE of an XML document when
% the DOCTYPE is defined by an external DTD.
%
:- type doctype
---> public(string) % Formal Public Identifier (FPI)
; public_system(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_dtd
% Generate and embed the entire DTD in the document
% (only available for method 2).
; external_dtd(doctype)
% Included a reference to an external DTD.
; no_dtd.
% Do not include any DOCTYPE information.
:- inst non_embedded_dtd
---> external_dtd(ground)
; no_dtd.
% Values of this type indicate whether a stylesheet reference should be
% included in a generated XML document.
%
:- type maybe_stylesheet
---> with_stylesheet(
stylesheet_type :: string, % For example "text/xsl"
stylesheet_href :: string
)
; no_stylesheet.
% write_xml_doc(Stream, Term, !State):
%
% Output Term as an XML document to the given stream.
% Term must be an instance of the xmlable typeclass.
%
:- pred write_xml_doc(Stream::in, T::in, State::di, State::uo)
is det <= (xmlable(T), stream.writer(Stream, string, State)).
% write_xml_doc_style_dtd(Stream, Term, MaybeStyleSheet, MaybeDTD,
% !State):
%
% Write Term to the given stream as an XML document.
% MaybeStyleSheet and MaybeDTD specify whether or not a stylesheet
% reference and/or a DTD should be included.
% Using this predicate, only external DTDs can be included, i.e.
% a DTD cannot be automatically generated and embedded
% (that feature is available only for method 2 -- see below).
%
:- pred write_xml_doc_style_dtd(Stream::in, T::in,
maybe_stylesheet::in, maybe_dtd::in(non_embedded_dtd),
State::di, State::uo) is det
<= (xmlable(T), stream.writer(Stream, string, State)).
% write_xml_element(Stream, Indent, Term, !State):
%
% Write Term out as XML to the given stream, using Indent as the
% indentation level (each indentation level is one tab character).
% No `<?xml ... ?>' header will be written.
% This is useful for generating large XML documents piecemeal.
%
:- pred write_xml_element(Stream::in, int::in, T::in,
State::di, State::uo) is det
<= (xmlable(T), stream.writer(Stream, string, State)).
% write_xml_header(Stream, MaybeEncoding, !State):
%
% Write an XML header (i.e. `<?xml version="1.0"?>) to the
% current file output stream.
% If MaybeEncoding is yes(Encoding), then include `encoding="Encoding"'
% in the header.
%
:- pred write_xml_header(Stream::in, maybe(string)::in,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
%-----------------------------------------------------------------------------%
%
% Method 2 interface
%
% Values of this type specify which mapping from functors to elements
% to use when generating XML. The role of a mapping is twofold:
% 1. To map functors to elements, and
% 2. To map functors to a set of attributes that should be
% generated for the corresponding element.
%
% We provide two predefined mappings:
%
% 1. simple: The functors `[]', `[|]' and `{}' are mapped to the
% elements `List', `Nil' and `Tuple' respectively. Arrays are
% assigned the `Array' element. The builtin types are assigned
% the elements `Int', `String', `Float' and `Char'. All other
% functors are assigned elements with the same name as the
% functor provided the functor name is well formed and does
% not start with a capital letter. Otherwise a mangled
% version of the functor name is used.
%
% All elements except `Int', `String', `Float' and `Char'
% will have their `functor', `arity', `type' and `field' (if
% there is a field name) attributes set. `Int', `String',
% `Float' and `Char' elements will just have their `type' and
% possibly their `field' attributes set.
%
% The `simple' mapping is designed to be easy to read and use,
% but may result in the same element being assigned to different
% functors.
%
% 2. unique: Here we use the same mapping as `simple' except
% we append the functor arity for discriminated unions and
% a mangled version of the type name for every element. The same
% attributes as the `simple' scheme are provided. The advantage
% of this scheme is that it maps each functor to a unique
% element. This means that it will always be possible to
% generate a DTD using this mapping so long as there is only
% one top level functor and no unsupported types can appear in
% terms of the type.
%
% A custom mapping can be provided using the `custom' functor. See the
% documentation for the element_pred type below for more information.
%
:- type element_mapping
---> simple
; unique
; custom(element_pred).
:- inst element_mapping
---> simple
; unique
; custom(element_pred).
% Deterministic procedures with the following signature can be used as
% custom functor to element mappings. The inputs to the procedure are
% a type and some information about a functor for that type
% if the type is a discriminated union. The output should be a well
% formed XML element name and a list of attributes that should be set
% for that element. See the types `maybe_functor_info' and
% `attr_from_source' below.
%
:- type element_pred == (pred(type_desc, maybe_functor_info, string,
list(attr_from_source))).
:- inst element_pred == (pred(in, in, out, out) is det).
% Values of this type are passed to custom functor-to-element
% mapping predicates to tell the predicate which functor to generate
% an element name for if the type is a discriminated union. If the
% type is not a discriminated union, then non_du is passed to
% the predicate when requesting an element for the type.
%
:- type maybe_functor_info
---> du_functor(
% The functor's name and arity.
functor_name :: string,
functor_arity :: int
)
; non_du.
% The type is not a discriminated union.
% Values of this type specify attributes that should be set from
% a particular source. The attribute_name field specifies the name
% of the attribute in the generated XML and the attribute_source
% field indicates where the attribute's value should come from.
%
:- type attr_from_source
---> attr_from_source(
attr_name :: string,
attr_source :: attr_source
).
% Possible attribute sources.
%
:- type attr_source
---> functor
% The original functor name as returned by
% deconstruct.deconstruct/5.
; field_name
% The field name if the functor appears in a
% named field (If the field is not named then this
% attribute is omitted).
; type_name
% The fully qualified type name the functor is for.
; arity.
% The arity of the functor as returned by
% deconstruct.deconstruct/5.
% To support third parties generating XML which is compatible with the
% XML generated using method 2, a DTD for a Mercury type can also be
% generated. A DTD for a given type and functor-to-element mapping may
% be generated provided the following conditions hold:
%
% 1. If the type is a discriminated union then there must be only
% one top-level functor for the type. This is because the top
% level functor will be used to generate the document type name.
%
% 2. The functor to element mapping must map each functor to a
% unique element name for every functor that could appear in
% terms of the type.
%
% 3. Only types whose terms consist of discriminated unions,
% arrays and the builtin types `int', `string', `character' and
% `float' can be used to automatically generate DTDs.
% Existential types are also not supported.
%
% The generated DTD is also a good reference when creating a stylesheet
% as it contains comments describing the mapping from functors to
% elements.
%
% Values of the following type indicate whether a DTD was successfully
% generated or not.
%
:- type dtd_generation_result
---> ok
; multiple_functors_for_root
% The root type is a discriminated union with
% multiple functors.
; duplicate_elements(
% The functor-to-element mapping maps different
% functors to the same element. The duplicate element
% and a list of types whose functors map to that
% element is given.
duplicate_element :: string,
duplicate_types :: list(type_desc)
)
; unsupported_dtd_type(type_desc)
% At the moment we only support generation of DTDs for types
% made up of discriminated unions, arrays, strings, ints,
% characters and floats. If a type is not supported, then it is
% returned as the argument of this functor.
; type_not_ground(pseudo_type_desc).
% If one of the arguments of a functor is existentially typed,
% then the pseudo_type_desc for the existentially quantified
% argument is returned as the argument of this functor.
% Since the values of existentially typed arguments can be of
% any type (provided any typeclass constraints are satisfied)
% it is not generally possible to generate DTD rules for functors
% with existentially typed arguments.
% write_xml_doc_general(Stream, Term, ElementMapping,
% MaybeStyleSheet, MaybeDTD, DTDResult, !State):
%
% Write Term to the given stream as an XML document using
% ElementMapping as the scheme to map functors to elements.
% MaybeStyleSheet and MaybeDTD specify whether or not a stylesheet
% reference and/or a DTD should be included. Any non-canonical terms
% will be canonicalized. If an embedded DTD is requested, but it is
% not possible to generate a DTD for Term using ElementMapping, then a
% value other than `ok' is returned in DTDResult and nothing is written
% out. See the dtd_generation_result type for a list of the other
% possible values of DTDResult and their meanings.
%
:- pred write_xml_doc_general(Stream::in, T::in,
element_mapping::in(element_mapping), maybe_stylesheet::in,
maybe_dtd::in, dtd_generation_result::out, State::di, State::uo) is det
<= stream.writer(Stream, string, State).
% write_xml_doc_general_cc(Stream, Term, ElementMapping, MaybeStyleSheet,
% MaybeDTD, DTDResult, !State):
%
% Write Term to the current file output stream as an XML document using
% ElementMapping as the scheme to map functors to elements.
% MaybeStyleSheet and MaybeDTD specify whether or not a stylesheet
% reference and/or a DTD should be included. Any non-canonical terms
% will be written out in full. If an embedded DTD is requested, but
% it is not possible to generate a DTD for Term using ElementMapping,
% then a value other than `ok' is returned in DTDResult and nothing is
% written out. See the dtd_generation_result type for a list of the
% other possible values of DTDResult and their meanings.
%
:- pred write_xml_doc_general_cc(Stream::in, T::in,
element_mapping::in(element_mapping), maybe_stylesheet::in,
maybe_dtd::in, dtd_generation_result::out, State::di, State::uo)
is cc_multi <= stream.writer(Stream, string, State).
% can_generate_dtd(ElementMapping, Type) = Result:
%
% Check if a DTD can be generated for the given Type using the
% functor-to-element mapping scheme ElementMapping. Return `ok' if it
% is possible to generate a DTD. See the documentation of the
% dtd_generation_result type for the meaning of the return value when
% it is not `ok'.
%
:- func can_generate_dtd(element_mapping::in(element_mapping),
type_desc::in) = (dtd_generation_result::out) is det.
% write_dtd(Stream, Term, ElementMapping, DTDResult, !State):
%
% Write a DTD for the given term to the current file output stream using
% ElementMapping to map functors to elements. If a DTD
% cannot be generated for Term using ElementMapping then a value
% other than `ok' is returned in DTDResult and nothing is written.
% See the dtd_generation_result type for a list of the other
% possible values of DTDResult and their meanings.
%
:- pred write_dtd(Stream::in, T::unused,
element_mapping::in(element_mapping), dtd_generation_result::out,
State::di, State::uo) is det
<= stream.writer(Stream, string, State).
% write_dtd_for_type(Stream, Type, ElementMapping, DTDResult, !State):
%
% Write a DTD for the given type to the given stream. If a
% DTD cannot be generated for Type using ElementMapping then a value
% other than `ok' is returned in DTDResult and nothing is written.
% See the dtd_generation_result type for a list of the other
% possible values of DTDResult and their meanings.
%
:- pred write_dtd_from_type(Stream::in, type_desc::in,
element_mapping::in(element_mapping), dtd_generation_result::out,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
% write_xml_element_general(Stream, NonCanon, MakeElement, IndentLevel,
% Term, !State):
%
% Write XML elements for the given term and all its descendents,
% using IndentLevel as the initial indentation level (each
% indentation level is one tab character) and using the MakeElement
% predicate to map functors to elements. No <?xml ... ?>
% header will be written. Non-canonical terms will be handled
% according to the value of NonCanon. See the deconstruct
% module in the standard library for more information on this argument.
%
:- pred write_xml_element_general(Stream, deconstruct.noncanon_handling,
element_mapping, int, T, State, State)
<= stream.writer(Stream, string, State).
:- mode write_xml_element_general(in, in(do_not_allow), in(element_mapping),
in, in, di, uo) is det.
:- mode write_xml_element_general(in, in(canonicalize), in(element_mapping),
in, in, di, uo) is det.
:- mode write_xml_element_general(in, in(include_details_cc),
in(element_mapping), in, in, di, uo) is cc_multi.
:- mode write_xml_element_general(in, in, in(element_mapping),
in, in, di, uo) is cc_multi.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module bool.
:- import_module char.
:- import_module construct.
:- import_module exception.
:- import_module int.
:- import_module map.
:- import_module string.
:- import_module unit.
:- import_module univ.
%-----------------------------------------------------------------------------%
write_xml_doc(Stream, Term, !State) :-
write_xml_doc_style_dtd(Stream, Term, no_stylesheet, no_dtd, !State).
write_xml_doc_style_dtd(Stream, Term, MaybeStyleSheet, MaybeDTD, !State) :-
write_xml_header(Stream, no, !State),
write_stylesheet_ref(Stream, MaybeStyleSheet, !State),
Root = to_xml(Term),
Root = elem(RootName, _, Children),
(
MaybeDTD = no_dtd
;
MaybeDTD = external_dtd(DocType),
write_external_doctype(Stream, RootName, DocType, !State)
),
( if contains_noformat_xml(Children) then
ChildrenFormat = no_format
else
ChildrenFormat = format
),
write_xml_element_format(Stream, ChildrenFormat, 0, Root, !State).
write_xml_element(Stream, Indent, Term, !State) :-
Root = to_xml(Term),
Root = elem(_, _, Children),
( if contains_noformat_xml(Children) then
ChildrenFormat = no_format
else
ChildrenFormat = format
),
write_xml_element_format(Stream, ChildrenFormat, Indent, Root, !State).
write_xml_doc_general(Stream, Term, ElementMapping, MaybeStyleSheet, MaybeDTD,
DTDResult, !State) :-
DTDResult = can_generate_dtd_2(MaybeDTD, ElementMapping, type_of(Term)),
(
DTDResult = ok,
write_xml_header(Stream, no, !State),
write_stylesheet_ref(Stream, MaybeStyleSheet, !State),
write_doctype(Stream, canonicalize, Term, ElementMapping, MaybeDTD, _,
!State),
write_xml_element_general(Stream, canonicalize, ElementMapping, 0,
Term, !State)
;
( DTDResult = multiple_functors_for_root
; DTDResult = duplicate_elements(_, _)
; DTDResult = unsupported_dtd_type(_)
; DTDResult = type_not_ground(_)
)
).
write_xml_doc_general_cc(Stream, Term, ElementMapping, MaybeStyleSheet,
MaybeDTD, DTDResult, !State) :-
DTDResult = can_generate_dtd_2(MaybeDTD, ElementMapping, type_of(Term)),
(
DTDResult = ok,
write_xml_header(Stream, no, !State),
write_stylesheet_ref(Stream, MaybeStyleSheet, !State),
write_doctype(Stream, include_details_cc, Term, ElementMapping,
MaybeDTD, _, !State),
write_xml_element_general(Stream, include_details_cc, ElementMapping,
0, Term, !State)
;
( DTDResult = multiple_functors_for_root
; DTDResult = duplicate_elements(_, _)
; DTDResult = unsupported_dtd_type(_)
; DTDResult = type_not_ground(_)
)
).
write_xml_element_general(Stream, NonCanon, ElementMapping, IndentLevel, Term,
!State) :-
type_to_univ(Term, Univ),
get_element_pred(ElementMapping, MakeElement),
write_xml_element_univ(Stream, NonCanon, MakeElement, IndentLevel, Univ,
[], _, !State).
write_dtd(Stream, Term, ElementMapping, DTDResult, !State) :-
type_of(Term) = TypeDesc,
write_dtd_from_type(Stream, TypeDesc, ElementMapping, DTDResult, !State).
write_xml_header(Stream, MaybeEncoding, !State) :-
put(Stream, "<?xml version=""1.0""", !State),
(
MaybeEncoding = yes(Encoding),
put(Stream, " encoding=""", !State),
put(Stream, Encoding, !State),
put(Stream, """?>\n", !State)
;
MaybeEncoding = no,
put(Stream, "?>\n", !State)
).
:- pred write_stylesheet_ref(Stream::in, maybe_stylesheet::in,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
write_stylesheet_ref(_, no_stylesheet, !State).
write_stylesheet_ref(Stream, with_stylesheet(Type, Href), !State) :-
put(Stream, "<?xml-stylesheet type=""", !State),
put(Stream, Type, !State),
put(Stream, """ href=""", !State),
put(Stream, Href, !State),
put(Stream, """?>\n", !State).
:- pred write_doctype(Stream, deconstruct.noncanon_handling, T,
element_mapping, maybe_dtd, dtd_generation_result, State, State)
<= stream.writer(Stream, string, State).
:- mode write_doctype(in, in(canonicalize), in, in(element_mapping), in, out,
di, uo) is det.
:- mode write_doctype(in, in(do_not_allow), in, in(element_mapping), in, out,
di, uo) is det.
:- mode write_doctype(in, in(include_details_cc), in, in(element_mapping),
in, out, di, uo) is cc_multi.
:- mode write_doctype(in, in, in, in(element_mapping), in, out,
di, uo) is cc_multi.
write_doctype(_, _, _, _, no_dtd, ok, !State).
write_doctype(Stream, _, T, ElementMapping, embed_dtd, DTDResult, !State) :-
write_dtd(Stream, T, ElementMapping, DTDResult, !State),
put(Stream, "\n", !State).
write_doctype(Stream, NonCanon, T, ElementMapping, external_dtd(DocType), ok,
!State) :-
get_element_pred(ElementMapping, MakeElement),
deconstruct.deconstruct(T, NonCanon, Functor, Arity, _),
( is_discriminated_union(type_of(T), _) ->
Request = du_functor(Functor, Arity)
;
Request = non_du
),
MakeElement(type_of(T), Request, Root, _),
write_external_doctype(Stream, Root, DocType, !State).
:- pred write_external_doctype(Stream::in, string::in, doctype::in,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
write_external_doctype(Stream, Root, DocType, !State) :-
put(Stream, "<!DOCTYPE ", !State),
put(Stream, Root, !State),
(
DocType = public(PUBLIC),
put(Stream, " PUBLIC """, !State),
put(Stream, PUBLIC, !State)
;
DocType = public_system(PUBLIC, SYSTEM),
put(Stream, " PUBLIC """, !State),
put(Stream, PUBLIC, !State),
put(Stream, """ """, !State),
put(Stream, SYSTEM, !State)
;
DocType = system(SYSTEM),
put(Stream, " SYSTEM """, !State),
put(Stream, SYSTEM, !State)
),
put(Stream, """>\n", !State).
% Implementation of the `unique' predefined mapping scheme.
%
:- pred make_unique_element(type_desc::in, maybe_functor_info::in,
string::out, list(attr_from_source)::out) is det.
make_unique_element(TypeDesc, du_functor(Functor, Arity), Element,
all_attr_sources) :-
( common_mercury_functor(Functor, ReservedElement) ->
MangledElement = ReservedElement
;
MangledElement = mangle(Functor)
),
Element = MangledElement ++ "--" ++ string.int_to_string(Arity) ++
"--" ++ mangle(type_name(TypeDesc)).
make_unique_element(TypeDesc, non_du, Element, AttrFromSources) :-
( is_primitive_type(TypeDesc, PrimitiveElement) ->
Element = PrimitiveElement,
AttrFromSources = [attr_from_source("type", type_name),
attr_from_source("field", field_name)]
; is_array(TypeDesc, _) ->
Element = array_element ++ "--" ++
mangle(type_name(TypeDesc)),
AttrFromSources = all_attr_sources
;
Element = mangle(type_name(TypeDesc)),
AttrFromSources = all_attr_sources
).
% Implementation of the `simple' mapping scheme.
%
:- pred make_simple_element(type_desc::in, maybe_functor_info::in,
string::out, list(attr_from_source)::out) is det.
make_simple_element(_, du_functor(Functor, _), Element, all_attr_sources) :-
( common_mercury_functor(Functor, ReservedElement) ->
Element = ReservedElement
;
Element = mangle(Functor)
).
make_simple_element(TypeDesc, non_du, Element, AttrFromSources) :-
( is_primitive_type(TypeDesc, PrimitiveElement) ->
Element = PrimitiveElement,
AttrFromSources = [attr_from_source("type", type_name),
attr_from_source("field", field_name)]
; is_array(TypeDesc, _) ->
Element = array_element,
AttrFromSources = all_attr_sources
;
Element = "Unknown",
AttrFromSources = all_attr_sources
).
:- func all_attr_sources = list(attr_from_source).
all_attr_sources = [
attr_from_source("functor", functor),
attr_from_source("field", field_name),
attr_from_source("type", type_name),
attr_from_source("arity", arity)
].
:- pred get_element_pred(element_mapping::in(element_mapping),
element_pred::out(element_pred)) is det.
get_element_pred(simple, make_simple_element).
get_element_pred(unique, make_unique_element).
get_element_pred(custom(P), P).
%-----------------------------------------------------------------------------%
%
% Some reserved element names for the predefined mapping schemes. Reserved
% element names all start with a capital letter so as not to conflict with a
% mangled element name.
%
% A prefix for functors that start with a capital letter or
% a non-letter.
%
:- func reserved_prefix = string.
reserved_prefix = "Tag_".
:- pred common_mercury_functor(string::in, string::out) 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").
:- 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.
%
% For example "my-functor!" would become "my-45functor-33".
% If we we where using "Tag_" as the prefix for strings that start with
% capital letters, then "MyFunctor" would become "Tag_MyFunctor".
%
:- func mangle(string) = string.
mangle(Functor) = Element :-
string.split(Functor, 1, Head, Tail),
(
string.is_all_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.
mangle_char(Chr, PrevChrs, list.append(PrevChrs, Chrs)) :-
% XXX This is system dependent since char.to_int is system dependent.
(
char.is_alnum_or_underscore(Chr)
->
Chrs = [Chr]
;
Chrs = ['-' | string.to_char_list(string.int_to_string(
char.to_int(Chr)))]
).
%-----------------------------------------------------------------------------%
% Return a list of elements, functors and arities
% (if the type is a discriminated union), argument types and
% attributes for all the functors for the type. Only one element
% will be in each list if the type is not a discriminated union.
%
:- pred get_elements_and_args(element_pred::in(element_pred),
type_desc::in, list(string)::out, list(maybe(string))::out,
list(maybe(int))::out, list(list(pseudo_type_desc))::out,
list(list(attr_from_source))::out) is det.
get_elements_and_args(MakeElement, TypeDesc, Elements, MaybeFunctors,
MaybeArities, ArgTypeLists, AttributeLists) :-
( is_discriminated_union(TypeDesc, NumFunctors) ->
FunctorNums = 0 .. (NumFunctors - 1),
(
list.map3(construct.get_functor(TypeDesc), FunctorNums,
Functors, Arities, ArgTypeLists0)
->
MaybeFunctors = list.map((func(X) = yes(X)), Functors),
MaybeArities = list.map((func(X) = yes(X)), Arities),
ArgTypeLists = ArgTypeLists0,
Requests = list.map_corresponding(make_du_functor,
Functors, Arities),
P = (pred(A::in, B::out, C::out) is det :-
MakeElement(TypeDesc, A, B, C)),
list.map2(P, Requests, Elements, AttributeLists)
;
throw(software_error(
"term_to_xml.get_elements_and_args: " ++
"get_functor failed for discriminated union"))
)
;
MakeElement(TypeDesc, non_du, Element, AttrFromSources),
Elements = [Element],
AttributeLists = [AttrFromSources],
MaybeFunctors = [no],
MaybeArities = [no],
(
is_array(TypeDesc, ArgType)
->
ArgTypeLists = [[ArgType]]
;
ArgTypeLists = [[]]
)
).
:- func make_du_functor(string, int) = maybe_functor_info.
make_du_functor(Functor, Arity) = du_functor(Functor, Arity).
:- pred primitive_value(univ::in, string::out) is semidet.
primitive_value(Univ, PrimValue) :-
( 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)
).
%-----------------------------------------------------------------------------%
% The following type is used to decide if an entity should be formatted
% (i.e. be indented and have a newline at the end). We do not format
% an entity if any of its siblings are anything besides an element,
% a CDATA entity or a comment, since then whitespaces are more likely
% to be significant. (Although technically spaces are always significant,
% they are usually interpreted as only formatting when they are between
% markup).
%
:- type maybe_format
---> format
; no_format.
:- pred write_xml_element_format(Stream::in, maybe_format::in, int::in, xml::in,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
write_xml_element_format(Stream, Format, IndentLevel,
elem(Name, Attrs, Children), !State) :-
maybe_indent(Stream, Format, IndentLevel, !State),
(
Children = [],
write_empty_element(Stream, Name, Attrs, !State),
maybe_nl(Stream, Format, !State)
;
Children = [_ | _],
write_element_start(Stream, Name, Attrs, !State),
( if contains_noformat_xml(Children) then
ChildrenFormat = no_format
else
ChildrenFormat = format,
put(Stream, "\n", !State)
),
list.foldl(write_xml_element_format(Stream, ChildrenFormat,
IndentLevel + 1), Children, !State),
maybe_indent(Stream, ChildrenFormat, IndentLevel, !State),
write_element_end(Stream, Name, !State),
maybe_nl(Stream, Format, !State)
).
write_xml_element_format(Stream, _, _, data(Data), !State) :-
write_xml_escaped_string(Stream, Data, !State).
write_xml_element_format(Stream, Format, IndentLevel, cdata(CData), !State) :-
maybe_indent(Stream, Format, IndentLevel, !State),
put(Stream, "<![CDATA[", !State),
put(Stream, CData, !State),
put(Stream, "]]>", !State),
maybe_nl(Stream, Format, !State).
write_xml_element_format(Stream, Format, IndentLevel, comment(Comment),
!State) :-
maybe_indent(Stream, Format, IndentLevel, !State),
put(Stream, "<!-- ", !State),
% Comments may not contain "--", so replace with " - ".
string.replace_all(Comment, "--", " - ", EscapedComment),
put(Stream, EscapedComment, !State),
put(Stream, " -->", !State),
maybe_nl(Stream, Format, !State).
write_xml_element_format(Stream, _, _, entity(EntityName), !State) :-
put(Stream, "&", !State),
put(Stream, EntityName ++ ";", !State).
write_xml_element_format(Stream, _, _, raw(RawString), !State) :-
put(Stream, RawString, !State).
:- func can_format_siblings(xml) = bool.
can_format_siblings(elem(_, _, _)) = yes.
can_format_siblings(data(_)) = no.
can_format_siblings(cdata(_)) = yes.
can_format_siblings(comment(_)) = yes.
can_format_siblings(raw(_)) = no.
can_format_siblings(entity(_)) = no.
:- pred contains_noformat_xml(list(xml)::in) is semidet.
contains_noformat_xml([XML | Rest]) :-
(
can_format_siblings(XML) = no
;
contains_noformat_xml(Rest)
).
:- pred maybe_nl(Stream::in, maybe_format::in, State::di, State::uo) is det
<= stream.writer(Stream, string, State).
maybe_nl(_Stream, no_format, !State).
maybe_nl(Stream, format, !State) :- put(Stream, "\n", !State).
:- pred maybe_indent(Stream::in, maybe_format::in, int::in,
State::di, State::uo) is det
<= stream.writer(Stream, string, State).
maybe_indent(Stream, Format, Indent, !State) :-
(
Format = format,
indent(Stream, Indent, !State)
;
Format = no_format
).
%-----------------------------------------------------------------------------%
:- pred write_xml_element_univ(Stream, deconstruct.noncanon_handling,
element_pred, int, univ, list(maybe(string)),
list(maybe(string)), State, State) <= stream.writer(Stream, string, State).
:- mode write_xml_element_univ(in, in(do_not_allow), in(element_pred), in, in,
in, out, di, uo) is det.
:- mode write_xml_element_univ(in, in(canonicalize), in(element_pred), in, in,
in, out, di, uo) is det.
:- mode write_xml_element_univ(in, in(include_details_cc), in(element_pred),
in, in, in, out, di, uo) is cc_multi.
:- mode write_xml_element_univ(in, in, in(element_pred), in, in, in, out, di,
uo) is cc_multi.
% Write an element and all its 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(Stream, NonCanon, MakeElement, IndentLevel, Univ,
MaybeFieldNames, RemainingMaybeFieldNames, !State) :-
(
MaybeFieldNames = [MaybeFieldName | RemainingMaybeFieldNames]
;
MaybeFieldNames = [],
RemainingMaybeFieldNames = [],
MaybeFieldName = no
),
deconstruct.deconstruct(Term, NonCanon, Functor, Arity, Args),
Term = univ_value(Univ),
TypeDesc = type_of(Term),
( is_discriminated_union(TypeDesc, _) ->
Request = du_functor(Functor, Arity)
;
Request = non_du
),
MakeElement(TypeDesc, Request, Element, AttrFromSources),
( primitive_value(Univ, PrimValue) ->
indent(Stream, IndentLevel, !State),
write_primitive_element_with_attr_from_source(Stream, Element,
AttrFromSources, PrimValue, MaybeFieldName, TypeDesc, !State)
;
(
Args = [],
indent(Stream, IndentLevel, !State),
write_empty_element_with_attr_from_source(Stream, Element,
AttrFromSources, yes(Functor), yes(Arity), MaybeFieldName,
TypeDesc, !State)
;
Args = [_ | _],
ChildMaybeFieldNames = get_field_names(TypeDesc, Functor, Arity),
indent(Stream, IndentLevel, !State),
write_element_start_with_attr_from_source(Stream, Element,
AttrFromSources, yes(Functor), yes(Arity), MaybeFieldName,
TypeDesc, !State),
write_child_xml_elements(Stream, NonCanon, MakeElement,
IndentLevel + 1, Args, ChildMaybeFieldNames, !State),
indent(Stream, IndentLevel, !State),
write_element_end(Stream, Element, !State),
put(Stream, "\n", !State)
)
).
:- 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, pseudo_type_desc::out) is semidet.
is_array(TypeDesc, ArgPseudoType) :-
PseudoTypeDesc = type_desc_to_pseudo_type_desc(TypeDesc),
pseudo_type_ctor_and_args(PseudoTypeDesc, TypeCtor, ArgPseudoTypes),
ArgPseudoTypes = [ArgPseudoType],
type_ctor_name(TypeCtor) = "array",
type_ctor_module_name(TypeCtor) = "array".
:- func get_field_names(type_desc, string, int) = list(maybe(string)).
get_field_names(TypeDesc, Functor, Arity) = MaybeFields :-
( is_discriminated_union(TypeDesc, NumFunctors) ->
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) :-
(
construct.get_functor_with_names(TypeDesc, FunctorNum,
Functor, Arity, _, FoundFieldNames)
->
MaybeFieldNames = FoundFieldNames
;
find_field_names(TypeDesc, FunctorNums, Functor, Arity,
MaybeFieldNames)
).
%-----------------------------------------------------------------------------%
:- pred write_child_xml_elements(Stream, deconstruct.noncanon_handling,
element_pred, int, list(univ), list(maybe(string)), State, State)
<= stream.writer(Stream, string, State).
:- mode write_child_xml_elements(in, in(do_not_allow), in(element_pred), in,
in, in, di, uo) is det.
:- mode write_child_xml_elements(in, in(canonicalize), in(element_pred), in,
in, in, di, uo) is det.
:- mode write_child_xml_elements(in, in(include_details_cc), in(element_pred),
in, in, in, di, uo) is cc_multi.
:- mode write_child_xml_elements(in, in, in(element_pred), in, in, in, di, uo)
is cc_multi.
write_child_xml_elements(Stream, NonCanon, MakeElement, IndentLevel, Args,
MaybeFieldNames, !State) :-
% The switch is needed because we can't pass write_xml_element_univ
% to foldl, since higher order terms with more than one mode can't be
% passed as arguments.
(
NonCanon = do_not_allow,
list.foldl2(
write_xml_element_univ_do_not_allow(Stream, MakeElement,
IndentLevel), Args,
MaybeFieldNames, _, !State)
;
NonCanon = canonicalize,
list.foldl2(
write_xml_element_univ_canonicalize(Stream, MakeElement,
IndentLevel), Args,
MaybeFieldNames, _, !State)
;
NonCanon = include_details_cc,
list.foldl2(
write_xml_element_univ_include_details_cc(Stream, MakeElement,
IndentLevel), Args,
MaybeFieldNames, _, !State)
).
:- pred write_xml_element_univ_do_not_allow(Stream::in,
element_pred::in(element_pred),
int::in, univ::in, list(maybe(string))::in, list(maybe(string))::out,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
write_xml_element_univ_do_not_allow(Stream, MakeElement, IndentLevel, Univ,
MaybeFieldNames0, MaybeFieldNames, !State) :-
write_xml_element_univ(Stream, do_not_allow, MakeElement, IndentLevel,
Univ, MaybeFieldNames0, MaybeFieldNames, !State).
:- pred write_xml_element_univ_canonicalize(Stream::in,
element_pred::in(element_pred),
int::in, univ::in, list(maybe(string))::in, list(maybe(string))::out,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
write_xml_element_univ_canonicalize(Stream, MakeElement, IndentLevel, Univ,
MaybeFieldNames0, MaybeFieldNames, !State) :-
write_xml_element_univ(Stream, canonicalize, MakeElement, IndentLevel,
Univ, MaybeFieldNames0, MaybeFieldNames, !State).
:- pred write_xml_element_univ_include_details_cc(Stream::in,
element_pred::in(element_pred), int::in, univ::in,
list(maybe(string))::in, list(maybe(string))::out, State::di, State::uo)
is cc_multi <= stream.writer(Stream, string, State).
write_xml_element_univ_include_details_cc(Stream, MakeElement, IndentLevel,
Univ, MaybeFieldNames0, MaybeFieldNames, !State) :-
write_xml_element_univ(Stream, include_details_cc, MakeElement,
IndentLevel, Univ, MaybeFieldNames0, MaybeFieldNames, !State).
%-----------------------------------------------------------------------------%
%
% Predicates for writing elements.
%
:- pred indent(Stream::in, int::in, State::di, State::uo) is det
<= stream.writer(Stream, string, State).
indent(Stream, IndentLevel, !State) :-
( IndentLevel > 0 ->
put(Stream, "\t", !State),
indent(Stream, IndentLevel - 1, !State)
;
true
).
:- pred write_primitive_element_with_attr_from_source(Stream::in, string::in,
list(attr_from_source)::in, string::in, maybe(string)::in,
type_desc::in, State::di, State::uo) is det
<= stream.writer(Stream, string, State).
write_primitive_element_with_attr_from_source(Stream, Element,
AttrFromSources, Value, MaybeField, TypeDesc, !State) :-
put(Stream, "<", !State),
put(Stream, Element, !State),
Attrs = make_attrs_from_sources(no, no,
TypeDesc, MaybeField, AttrFromSources),
list.foldl(write_attribute(Stream), Attrs, !State),
put(Stream, ">", !State),
write_xml_escaped_string(Stream, Value, !State),
put(Stream, "</", !State),
put(Stream, Element, !State),
put(Stream, ">\n", !State).
:- pred write_element_start_with_attr_from_source(Stream::in, string::in,
list(attr_from_source)::in,
maybe(string)::in, maybe(int)::in, maybe(string)::in,
type_desc::in, State::di, State::uo) is det
<= stream.writer(Stream, string, State).
write_element_start_with_attr_from_source(Stream, Element, AttrFromSources,
MaybeFunctor, MaybeArity, MaybeField, TypeDesc, !State) :-
Attrs = make_attrs_from_sources(MaybeFunctor, MaybeArity,
TypeDesc, MaybeField, AttrFromSources),
write_element_start(Stream, Element, Attrs, !State),
put(Stream, "\n", !State).
:- pred write_element_start(Stream::in, string::in, list(attr)::in,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
write_element_start(Stream, Element, Attributes, !State) :-
put(Stream, "<", !State),
put(Stream, Element, !State),
list.foldl(write_attribute(Stream), Attributes, !State),
put(Stream, ">", !State).
:- pred write_empty_element_with_attr_from_source(Stream::in, string::in,
list(attr_from_source)::in, maybe(string)::in, maybe(int)::in,
maybe(string)::in, type_desc::in, State::di, State::uo) is det
<= stream.writer(Stream, string, State).
write_empty_element_with_attr_from_source(Stream, Element, AttrFromSources,
MaybeFunctor, MaybeArity, MaybeField, TypeDesc, !State) :-
Attrs = make_attrs_from_sources(MaybeFunctor, MaybeArity,
TypeDesc, MaybeField, AttrFromSources),
write_empty_element(Stream, Element, Attrs, !State),
put(Stream, "\n", !State).
:- pred write_empty_element(Stream::in, string::in, list(attr)::in,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
write_empty_element(Stream, Element, Attributes, !State) :-
put(Stream, "<", !State),
put(Stream, Element, !State),
list.foldl(write_attribute(Stream), Attributes, !State),
put(Stream, " />", !State).
:- pred write_element_end(Stream::in, string::in, State::di, State::uo) is det
<= stream.writer(Stream, string, State).
write_element_end(Stream, Element, !State) :-
put(Stream, "</", !State),
put(Stream, Element, !State),
put(Stream, ">", !State).
:- func attr_from_source_to_maybe_attr(maybe(string), maybe(int), type_desc,
maybe(string), attr_from_source) = maybe(attr).
attr_from_source_to_maybe_attr(MaybeFunctor, MaybeArity, TypeDesc,
MaybeFieldName, attr_from_source(Name, Source)) = MaybeAttr :-
(
Source = functor,
(
MaybeFunctor = yes(Functor),
MaybeAttr = yes(attr(Name, Functor))
;
MaybeFunctor = no,
MaybeAttr = no
)
;
Source = arity,
(
MaybeArity = yes(Arity),
MaybeAttr = yes(attr(Name,
string.int_to_string(Arity)))
;
MaybeArity = no,
MaybeAttr = no
)
;
Source = type_name,
MaybeAttr = yes(attr(Name, type_name(TypeDesc)))
;
Source = field_name,
(
MaybeFieldName = yes(FieldName),
MaybeAttr = yes(attr(Name, FieldName))
;
MaybeFieldName = no,
MaybeAttr = no
)
).
:- func make_attrs_from_sources(maybe(string), maybe(int), type_desc,
maybe(string), list(attr_from_source)) = list(attr).
make_attrs_from_sources(MaybeFunctor, MaybeArity, TypeDesc, MaybeField,
AttrFromSources) = Attrs :-
MaybeAttrs = list.map(attr_from_source_to_maybe_attr(MaybeFunctor,
MaybeArity, TypeDesc, MaybeField), AttrFromSources),
list.filter_map(is_maybe_yes, MaybeAttrs, Attrs).
:- pred is_maybe_yes(maybe(T)::in, T::out) is semidet.
is_maybe_yes(yes(X), X).
:- pred write_attribute(Stream::in, attr::in, State::di, State::uo) is det
<= stream.writer(Stream, string, State).
write_attribute(Stream, attr(Name, Value), !State) :-
put(Stream, " ", !State),
put(Stream, Name, !State),
put(Stream, "=""", !State),
write_xml_escaped_string(Stream, Value, !State),
put(Stream, """", !State).
:- pred write_xml_escaped_string(Stream::in, string::in,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
write_xml_escaped_string(Stream, Str, !State) :-
string.foldl(write_xml_escaped_char(Stream), Str, !State).
:- pred write_xml_escaped_char(Stream::in, char::in, State::di, State::uo)
is det <= stream.writer(Stream, string, State).
write_xml_escaped_char(Stream, Chr, !State) :-
( xml_predefined_entity(Chr, Str) ->
put(Stream, Str, !State)
;
put(Stream, string.from_char(Chr), !State)
).
:- pred xml_predefined_entity(char::in, string::out) is semidet.
xml_predefined_entity(('<'), "&lt;").
xml_predefined_entity(('>'), "&gt;").
xml_predefined_entity(('&'), "&amp;").
xml_predefined_entity(('\''), "&apos;").
xml_predefined_entity(('\"'), "&quot;").
%-----------------------------------------------------------------------------%
%
% Predicates to write the DTD for a type.
%
write_dtd_from_type(Stream, TypeDesc, ElementMapping, DTDResult, !State) :-
DTDResult = can_generate_dtd(ElementMapping, TypeDesc),
(
DTDResult = ok,
get_element_pred(ElementMapping, MakeElement),
(
get_elements_and_args(MakeElement, TypeDesc,
[RootElement], [_], [_], [PseudoArgTypes], _)
->
ArgTypes = list.map(det_ground_pseudo_type_desc_to_type_desc,
PseudoArgTypes),
put(Stream, "<!DOCTYPE ", !State),
put(Stream, RootElement, !State),
put(Stream, " [\n\n", !State),
write_dtd_types(Stream, MakeElement, [TypeDesc | ArgTypes],
map.init, !State),
put(Stream, "\n]>", !State),
DTDResult = ok
;
throw(software_error("term_to_xml.write_dtd_from_type"
++ ": not ok to generate DTD"))
)
;
( DTDResult = multiple_functors_for_root
; DTDResult = duplicate_elements(_, _)
; DTDResult = unsupported_dtd_type(_)
; DTDResult = type_not_ground(_)
)
).
can_generate_dtd(ElementMapping, TypeDesc) = Result :-
get_element_pred(ElementMapping, MakeElement),
( get_elements_and_args(MakeElement, TypeDesc, [_], [_], [_], [_], [_]) ->
PseudoTypeDesc = type_desc_to_pseudo_type_desc(TypeDesc),
Result = can_generate_dtd_for_types(MakeElement, [PseudoTypeDesc],
map.init, map.init)
;
Result = multiple_functors_for_root
).
:- func can_generate_dtd_2(maybe_dtd::in, element_mapping::in(element_mapping),
type_desc::in) = (dtd_generation_result::out) is det.
can_generate_dtd_2(no_dtd, _, _) = ok.
can_generate_dtd_2(external_dtd(_), _, _) = ok.
can_generate_dtd_2(embed_dtd, ElementMapping, TypeDesc)
= can_generate_dtd(ElementMapping, TypeDesc).
% Check that we can reliably generate a DTD for the types in the list.
% At the moment this means each type (and all the types of the
% arguments of functors of the type if it is a discriminated union)
% must be either a discriminated union, an array, an int, a
% character, a float or a string and must not be existentially
% quantified.
%
:- func can_generate_dtd_for_types(element_pred::in(element_pred),
list(pseudo_type_desc)::in,
map(type_desc, unit)::in, map(string, type_desc)::in) =
(dtd_generation_result::out) is det.
can_generate_dtd_for_types(_, [], _, _) = ok.
can_generate_dtd_for_types(MakeElement, [PseudoTypeDesc | PseudoTypeDescs],
Done, ElementsSoFar) = Result :-
(
TypeDesc = ground_pseudo_type_desc_to_type_desc(
PseudoTypeDesc)
->
(
(
is_discriminated_union(TypeDesc, _)
;
is_array(TypeDesc, _)
;
is_primitive_type(TypeDesc, _)
)
->
( map.contains(Done, TypeDesc) ->
Result = can_generate_dtd_for_types(MakeElement,
PseudoTypeDescs, Done, ElementsSoFar)
;
get_elements_and_args(MakeElement, TypeDesc, Elements, _, _,
ArgLists, _),
list.filter(map.contains(ElementsSoFar), Elements,
DupElements),
(
DupElements = [DupElement | _],
map.lookup(ElementsSoFar, DupElement, DupTypeDesc),
DupTypes = [TypeDesc, DupTypeDesc],
Result = duplicate_elements(DupElement, DupTypes)
;
DupElements = [],
list.merge_and_remove_dups(list.condense(ArgLists),
PseudoTypeDescs, NewPseudoTypeDescs),
list.duplicate(length(Elements), TypeDesc, TypeDescList),
map.det_insert_from_corresponding_lists(Elements,
TypeDescList, ElementsSoFar, NewElementsSoFar),
map.det_insert(TypeDesc, unit, Done, NewDone),
Result = can_generate_dtd_for_types(MakeElement,
NewPseudoTypeDescs, NewDone, NewElementsSoFar)
)
)
;
Result = unsupported_dtd_type(TypeDesc)
)
;
Result = type_not_ground(PseudoTypeDesc)
).
% Write out the DTD entries for all the given types and add the written
% types to AlreadyDone. Children types found along the way are added
% to the first argument. We stop when all the types have had their DTD
% entry written.
%
:- pred write_dtd_types(Stream::in, element_pred::in(element_pred),
list(type_desc)::in, map(type_desc, unit)::in,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
write_dtd_types(_, _, [], _, !State).
write_dtd_types(Stream, MakeElement, [TypeDesc | TypeDescs], AlreadyDone,
!State) :-
( map.search(AlreadyDone, TypeDesc, _) ->
write_dtd_types(Stream, MakeElement, TypeDescs, AlreadyDone, !State)
;
write_dtd_type_elements(Stream, MakeElement, TypeDesc, ChildArgTypes,
!State),
map.set(TypeDesc, unit, AlreadyDone, NewAlreadyDone),
write_dtd_types(Stream, MakeElement, append(ChildArgTypes, TypeDescs),
NewAlreadyDone, !State)
).
% Write the IMPLIED, FIXED or REQUIRED part of the ATTLIST entry.
%
:- pred write_attribute_source_kind(Stream::in, attr_source::in,
maybe(string)::in, State::di, State::uo) is det
<= stream.writer(Stream, string, State).
write_attribute_source_kind(Stream, functor, no, !State) :-
put(Stream, "#IMPLIED", !State).
write_attribute_source_kind(Stream, functor, yes(Value), !State) :-
put(Stream, "#FIXED """, !State),
write_xml_escaped_string(Stream, Value, !State),
put(Stream, """", !State).
write_attribute_source_kind(Stream, field_name, _, !State) :-
put(Stream, "#IMPLIED", !State).
write_attribute_source_kind(Stream, type_name, no, !State) :-
put(Stream, "#REQUIRED", !State).
write_attribute_source_kind(Stream, type_name, yes(Value), !State) :-
put(Stream, "#FIXED """, !State),
write_xml_escaped_string(Stream, Value, !State),
put(Stream, """", !State).
write_attribute_source_kind(Stream, arity, no, !State) :-
put(Stream, "#IMPLIED", !State).
write_attribute_source_kind(Stream, arity, yes(Value), !State) :-
put(Stream, "#FIXED """, !State),
write_xml_escaped_string(Stream, Value, !State),
put(Stream, """", !State).
% Write an ATTLIST entry for the given attribute.
%
:- pred write_dtd_attlist(Stream::in, string::in, maybe(string)::in,
maybe(int)::in, type_desc::in, attr_from_source::in,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
write_dtd_attlist(Stream, Element, MaybeFunctor, MaybeArity, TypeDesc,
attr_from_source(Name, Source), !State) :-
(
Source = functor,
MaybeValue = MaybeFunctor
;
Source = arity,
(
MaybeArity = yes(Arity),
MaybeValue = yes(string.int_to_string(Arity))
;
MaybeArity = no,
MaybeValue = no
)
;
Source = type_name,
MaybeValue = yes(type_name(TypeDesc))
;
Source = field_name,
MaybeValue = no
),
put(Stream, "<!ATTLIST ", !State),
put(Stream, Element, !State),
put(Stream, " ", !State),
put(Stream, Name, !State),
put(Stream, " CDATA ", !State),
write_attribute_source_kind(Stream, Source, MaybeValue, !State),
put(Stream, ">\n", !State).
:- pred write_dtd_attlists(Stream::in, string::in, list(attr_from_source)::in,
maybe(string)::in, maybe(int)::in, type_desc::in,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
write_dtd_attlists(Stream, Element, AttrFromSources, MaybeFunctor, MaybeArity,
TypeDesc, !State) :-
list.foldl(write_dtd_attlist(Stream, Element, MaybeFunctor, MaybeArity,
TypeDesc), AttrFromSources, !State).
% Write DTD entries for all the functors for a type.
%
:- pred write_dtd_type_elements(Stream::in, element_pred::in(element_pred),
type_desc::in, list(type_desc)::out,
State::di, State::uo) is det <= stream.writer(Stream, string, State).
write_dtd_type_elements(Stream, MakeElement, TypeDesc, ChildArgTypes, !State)
:-
get_elements_and_args(MakeElement, TypeDesc, Elements,
MaybeFunctors, MaybeArities, ArgPseudoTypeLists,
AttributeLists),
ArgTypeLists = list.map(list.map(
det_ground_pseudo_type_desc_to_type_desc), ArgPseudoTypeLists),
list.condense(ArgTypeLists, ChildArgTypes),
put(Stream, "<!-- Elements for functors of type """, !State),
write_xml_escaped_string(Stream, type_name(TypeDesc), !State),
put(Stream, """ -->\n\n", !State),
write_dtd_entries(Stream, MakeElement, TypeDesc, Elements, MaybeFunctors,
MaybeArities, ArgTypeLists, AttributeLists, !State).
:- pred write_dtd_entries(Stream::in, element_pred::in(element_pred),
type_desc::in, list(string)::in, list(maybe(string))::in,
list(maybe(int))::in, list(list(type_desc))::in,
list(list(attr_from_source))::in, State::di, State::uo) is det
<= stream.writer(Stream, string, State).
% Write all the given DTD entries.
%
write_dtd_entries(_, _, _, [], _, _, _, _, !State).
write_dtd_entries(Stream, MakeElement, TypeDesc, [Element | Elements],
MaybeFunctorList, MaybeArityList, ArgTypeListList,
AttributeListList, !State) :-
MaybeFunctor = list.det_head(MaybeFunctorList),
MaybeFunctors = list.det_tail(MaybeFunctorList),
MaybeArity = list.det_head(MaybeArityList),
MaybeArities = list.det_tail(MaybeArityList),
ArgTypeList = list.det_head(ArgTypeListList),
ArgTypeLists = list.det_tail(ArgTypeListList),
AttributeList = list.det_head(AttributeListList),
AttributeLists = list.det_tail(AttributeListList),
put(Stream, "<!ELEMENT ", !State),
put(Stream, Element, !State),
put(Stream, " ", !State),
(
is_primitive_type(TypeDesc, _)
->
put(Stream, "(#PCDATA)>\n", !State)
;
(
ArgTypeList = [],
put(Stream, "EMPTY>\n", !State)
;
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, _) ->
put(Stream, "(", !State)
;
true
),
(
Braces = yes,
put(Stream, "(", !State)
;
Braces = no
),
AllowedFunctorsRegexs = list.map(
dtd_allowed_functors_regex(MakeElement), ArgTypeList),
AllowedFunctorsRegex =
string.join_list(",", AllowedFunctorsRegexs),
put(Stream, AllowedFunctorsRegex, !State),
(
Braces = yes,
put(Stream, ")", !State)
;
Braces = no
),
( is_array(TypeDesc, _) ->
put(Stream, "*)", !State)
;
true
),
put(Stream, ">\n", !State)
)
),
write_dtd_attlists(Stream, Element, AttributeList, MaybeFunctor,
MaybeArity, TypeDesc, !State),
put(Stream, "\n", !State),
write_dtd_entries(Stream, MakeElement, TypeDesc, Elements, MaybeFunctors,
MaybeArities, ArgTypeLists, AttributeLists, !State).
% Return the allowed functors for the type as a DTD rule regular
% expression.
%
:- func dtd_allowed_functors_regex(element_pred::in(element_pred),
type_desc::in) = (string::out) is det.
dtd_allowed_functors_regex(MakeElement, TypeDesc) = Regex :-
get_elements_and_args(MakeElement, TypeDesc, Elements, _, _, _, _),
ElementsStr = string.join_list("|", Elements),
( length(Elements) > 1 ->
Regex = "(" ++ ElementsStr ++ ")"
;
Regex = ElementsStr
).
%-----------------------------------------------------------------------------%
:- end_module term_to_xml.
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink