%---------------------------------------------------------------------------% % 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 2 can automatically generate DTDs, while method 1 cannot. % % Method 1 allows values of a specific type to be mapped to arbitrary XML % elements with arbitrary children and arbitrary attributes. % With 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. % % 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 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 either a full XML document % or a portion of one. % :- 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 `<', `>', `&', `'' % and `"' respectively. ; cdata(string) % Data to be enclosed in `' tags. % The string may not contain "]]>" as a substring. % If it does, then the generated XML will be invalid. ; comment(string) % An XML comment. The comment should not include % the `'. 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 `' 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. `) 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, 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 not supported either. % % 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 arguments identify the duplicate % element and a list of the types whose functors map % to that element. 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 component 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 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 int. :- import_module map. :- import_module require. :- 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, "\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(Stream, MaybeStyleSheet, !State) :- ( MaybeStyleSheet = no_stylesheet ; MaybeStyleSheet = with_stylesheet(Type, Href), 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(Stream, NonCanon, Term, ElementMapping, MaybeDTD, DTDResult, !State) :- ( MaybeDTD = no_dtd, DTDResult = ok ; MaybeDTD = embed_dtd, write_dtd(Stream, Term, ElementMapping, DTDResult, !State), put(Stream, "\n", !State) ; MaybeDTD = external_dtd(DocType), get_element_pred(ElementMapping, MakeElement), deconstruct.deconstruct(Term, NonCanon, Functor, Arity, _), TypeOfTerm = type_of(Term), ( if is_discriminated_union(TypeOfTerm, _) then Request = du_functor(Functor, Arity) else Request = non_du ), MakeElement(TypeOfTerm, Request, Root, _), write_external_doctype(Stream, Root, DocType, !State), DTDResult = ok ). :- 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, "\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, MaybeFunctorInfo, Element, AttrFromSources) :- ( MaybeFunctorInfo = du_functor(Functor, Arity), MangledElement = maybe_mangle_uncommon_functor(Functor), Element = MangledElement ++ "--" ++ string.int_to_string(Arity) ++ "--" ++ mangle(type_name(TypeDesc)), AttrFromSources = all_attr_sources ; MaybeFunctorInfo = non_du, ( if is_primitive_type(TypeDesc, PrimitiveElement) then Element = PrimitiveElement, AttrFromSources = [attr_from_source("type", type_name), attr_from_source("field", field_name)] else if is_array(TypeDesc, _) then Element = array_element ++ "--" ++ mangle(type_name(TypeDesc)), AttrFromSources = all_attr_sources else 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(TypeDesc, MaybeFunctorInfo, Element, AttrFromSources) :- ( MaybeFunctorInfo = du_functor(Functor, _), Element = maybe_mangle_uncommon_functor(Functor), AttrFromSources = all_attr_sources ; MaybeFunctorInfo = non_du, ( if is_primitive_type(TypeDesc, PrimitiveElement) then Element = PrimitiveElement, AttrFromSources = [attr_from_source("type", type_name), attr_from_source("field", field_name)] else if is_array(TypeDesc, _) then Element = array_element, AttrFromSources = all_attr_sources else 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 maybe_mangle_uncommon_functor(string) = string. maybe_mangle_uncommon_functor(Functor) = Element :- ( if common_mercury_functor(Functor, ReservedElement) then Element = ReservedElement else Element = mangle(Functor) ). :- func array_element = string. array_element = "Array". :- pred is_primitive_type(type_desc::in, string::out) is semidet. is_primitive_type(TypeDesc, Element) :- ( if TypeDesc = type_of("") then Element = "String" else if TypeDesc = type_of('c') then Element = "Char" else if TypeDesc = type_of(1) then Element = "Int" else if TypeDesc = type_of(1.0) then Element = "Float" else fail ). %---------------------------------------------------------------------------% % % 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 alphanumeric 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), ( if string.is_all_alpha(Head), string.to_lower(Head) = Head then First = Head, Rest = Tail else 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. ( if char.is_alnum_or_underscore(Chr) then Chrs = [Chr] else 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) :- ( if is_discriminated_union(TypeDesc, NumFunctors) then FunctorNums = 0 .. (NumFunctors - 1), ( if list.map3(construct.get_functor(TypeDesc), FunctorNums, Functors, Arities, ArgTypeLists0) then 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) else unexpected($module, $pred, "get_functor failed for discriminated union") ) else MakeElement(TypeDesc, non_du, Element, AttrFromSources), Elements = [Element], AttributeLists = [AttrFromSources], MaybeFunctors = [no], MaybeArities = [no], ( if is_array(TypeDesc, ArgType) then ArgTypeLists = [[ArgType]] else 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) :- ( if univ_to_type(Univ, String) then PrimValue = String`with_type`string else if univ_to_type(Univ, Char) then PrimValue = char_to_string(Char) else if univ_to_type(Univ, Int) then PrimValue = int_to_string(Int) else 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, XML, !State) :- ( XML = elem(Name, Attrs, Children), 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) ) ; XML = data(Data), write_xml_escaped_string(Stream, Data, !State) ; XML = cdata(CData), maybe_indent(Stream, Format, IndentLevel, !State), put(Stream, "", !State), maybe_nl(Stream, Format, !State) ; XML = comment(Comment), maybe_indent(Stream, Format, IndentLevel, !State), put(Stream, "", !State), maybe_nl(Stream, Format, !State) ; XML = entity(EntityName), put(Stream, "&", !State), put(Stream, EntityName ++ ";", !State) ; XML = raw(RawString), 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 ). %---------------------------------------------------------------------------% % write_xml_element_univ(Stream, NonCanon, MakeElement, IndentLevel, Univ, % MaybeFieldNames, RemainingMaybeFieldNames, !State): % % 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. % :- 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_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), ( if is_discriminated_union(TypeDesc, _) then Request = du_functor(Functor, Arity) else Request = non_du ), MakeElement(TypeDesc, Request, Element, AttrFromSources), ( if primitive_value(Univ, PrimValue) then indent(Stream, IndentLevel, !State), write_primitive_element_with_attr_from_source(Stream, Element, AttrFromSources, PrimValue, MaybeFieldName, TypeDesc, !State) else ( 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 :- ( if is_discriminated_union(TypeDesc, NumFunctors) then FunctorNums = 0 .. (NumFunctors - 1), ( if find_field_names(TypeDesc, FunctorNums, Functor, Arity, FoundMaybeFields) then MaybeFields = FoundMaybeFields else MaybeFields = [] ) else 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) :- ( if construct.get_functor_with_names(TypeDesc, FunctorNum, Functor, Arity, _, FoundFieldNames) then MaybeFieldNames = FoundFieldNames else 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) :- % Higher order terms with more than one mode can't be passed as arguments, % so we can't pass write_xml_element_univ to foldl2. Hence we need % this switch. ( 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) :- ( if IndentLevel > 0 then put(Stream, "\t", !State), indent(Stream, IndentLevel - 1, !State) else 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, "\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). :- 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) :- ( if xml_predefined_entity(Chr, Str) then put(Stream, Str, !State) else put(Stream, string.from_char(Chr), !State) ). :- 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(Stream, TypeDesc, ElementMapping, DTDResult, !State) :- DTDResult = can_generate_dtd(ElementMapping, TypeDesc), ( DTDResult = ok, get_element_pred(ElementMapping, MakeElement), ( if get_elements_and_args(MakeElement, TypeDesc, [RootElement], [_], [_], [PseudoArgTypes], _) then ArgTypes = list.map(det_ground_pseudo_type_desc_to_type_desc, PseudoArgTypes), put(Stream, "", !State), DTDResult = ok else unexpected($module, $pred, "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), ( if get_elements_and_args(MakeElement, TypeDesc, [_], [_], [_], [_], [_]) then PseudoTypeDesc = type_desc_to_pseudo_type_desc(TypeDesc), Result = can_generate_dtd_for_types(MakeElement, [PseudoTypeDesc], map.init, map.init) else 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 :- ( if TypeDesc = ground_pseudo_type_desc_to_type_desc(PseudoTypeDesc) then ( if ( is_discriminated_union(TypeDesc, _) ; is_array(TypeDesc, _) ; is_primitive_type(TypeDesc, _) ) then ( if map.contains(Done, TypeDesc) then Result = can_generate_dtd_for_types(MakeElement, PseudoTypeDescs, Done, ElementsSoFar) else 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) ) ) else Result = unsupported_dtd_type(TypeDesc) ) else 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) :- ( if map.search(AlreadyDone, TypeDesc, _) then write_dtd_types(Stream, MakeElement, TypeDescs, AlreadyDone, !State) else 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, "\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, "\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, "\n", !State) else ( ArgTypeList = [], put(Stream, "EMPTY>\n", !State) ; ArgTypeList = [Head | Tail], ( Tail = [_ | _], Braces = yes ; Tail = [], ( if num_functors(Head) > 1 then Braces = no else Braces = yes ) ), % Put extra braces for arrays for the * at the end. ( if is_array(TypeDesc, _) then put(Stream, "(", !State) else 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 ), ( if is_array(TypeDesc, _) then put(Stream, "*)", !State) else 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), ( if length(Elements) > 1 then Regex = "(" ++ ElementsStr ++ ")" else Regex = ElementsStr ). %---------------------------------------------------------------------------% :- end_module term_to_xml. %---------------------------------------------------------------------------%