mercury/tests/hard_coded/write_xml.m

:- module write_xml.

:- interface.

:- import_module io.

:- pred main(io::di, io::uo) is cc_multi.

:- implementation.

:- import_module array.
:- import_module bool.
:- import_module char.
:- import_module float.
:- import_module int.
:- import_module list.
:- import_module map.
:- import_module std_util.
:- import_module string.
:- import_module term_to_xml.
:- import_module type_desc.

:- type mytype
	--->	hello(field1::string, 'Field<2>'::int, char,
			'another field'::float, bool)
	;	'List'(list(listPart))
	;	'Tag-'(int)
	;	'String'(string)
	;	a_tuple({string, int, {char, float}})
	;	a_map(map(int, string))
	;	a_pred(pred(int))
	;	'a <!@#$%^&*()> functor name!!!'(int)
	;	t(type_desc)
	;	ctor(type_ctor_desc)
	;	pointer(c_pointer)
	;	foreign(ftype).

:- type listPart ---> listPart(int) ; nothing.

:- type a == array(mytype).

:- type ftype.

:- pred make_ftype(ftype::out) is det.

:- pragma foreign_type("C", ftype, "int").
:- pragma foreign_type("C#", ftype, "object").
:- pragma foreign_type("Java", ftype, "Integer").
:- pragma foreign_type("Erlang", ftype, "").

:- pragma foreign_proc("C", make_ftype(F::out),
	[will_not_call_mercury, thread_safe, promise_pure],
"
	F = 1;
").

:- pragma foreign_proc("C#", make_ftype(F::out),
	[will_not_call_mercury, thread_safe, promise_pure],
"
	F = 1;
").

:- pragma foreign_proc("Java", make_ftype(F::out),
	[will_not_call_mercury, thread_safe, promise_pure],
"
	F = 1;
").

:- pragma foreign_proc("Erlang", make_ftype(F::out),
	[will_not_call_mercury, thread_safe, promise_pure],
"
	F = 1
").

:- pred make_pointer(c_pointer::out) is det.

:- pragma foreign_proc("C", make_pointer(P::out),
	[will_not_call_mercury, thread_safe, promise_pure],
"
	P = (MR_Word) NULL;
").

:- pragma foreign_proc("C#", make_pointer(P::out),
	[will_not_call_mercury, thread_safe, promise_pure],
"
	P = null;
").

:- pragma foreign_proc("Java", make_pointer(P::out),
	[will_not_call_mercury, thread_safe, promise_pure],
"
	P = null;
").

:- pragma foreign_proc("Erlang", make_pointer(P::out),
	[will_not_call_mercury, thread_safe, promise_pure],
"
	P = null
").

:- pred p(int::in, int::in, mytype::in, int::out) is det.

p(_, _, _, 1).

:- type wrap(T) ---> wrap(T).

:- pred p1(type_desc::in, maybe_functor_info::in, string::out,
	list(attr_from_source)::out) is det.

p1(_, _, "X", []).

:- type ext ---> some [T] ext(ext_field_1::T).

main(!IO) :-
	StdOut = io.stdout_stream,
	some [!M] (
	map.init(!:M),
	map.set(1, "hello", !M),
	map.set(2, "hello1", !M),
	map.set(3, "hello2", !M),
	map.set(4, "hello3", !M),
	map.set(5, "hello4", !M),
	map.set(6, "hello5", !M),
	map.set(7, "hello6", !M),
	map.set(8, "hello7", !M),
	make_ftype(F),
	make_pointer(P),
	X = [
		'Tag-'(44),
		'String'("a string"),
		hello("this \n\nis a <string>&", -123, '<', 1.123, yes),
		a_tuple({"some more stuf", 123456,
			{a, 123.55322522e-99}}),
		'List'([listPart(1),
			listPart(2),
			nothing,
			listPart(4),
			nothing,
			listPart(6),
			listPart(7),
			listPart(8),
			nothing]),
		a_map(!.M), 'a <!@#$%^&*()> functor name!!!'(999),
		a_pred(p(1, 2, hello("a string", 1, 'c', -0.00001e-10, yes))),
		t(type_of(!.M)),
		ctor(type_ctor(type_of(!.M))),
		foreign(F),
		pointer(P)],
	Map = !.M
	),
	array.from_list(X, A),
	write_xml_doc_general_cc(StdOut, A, unique, with_stylesheet("text/css",
		"http://www.cs.mu.oz.au/a_css.css"), embed_dtd, Result1, !IO),
	write_string("Result 1:\n", !IO),
	write(Result1, !IO),
	nl(!IO),
	nl(!IO),
	write_xml_doc_general_cc(StdOut, A, unique, with_stylesheet("text/css",
		"http://www.cs.mu.oz.au/a_css.css"), no_dtd, Result2, !IO),
	write_string("Result 2:\n", !IO),
	write(Result2, !IO),
	nl(!IO),
	nl(!IO),
	write_xml_doc_general_cc(StdOut, wrap(Map), unique,
		with_stylesheet("text/css",
		"http://www.cs.mu.oz.au/a_css.css"), embed_dtd, Result3, !IO),
	write_string("Result 3:\n", !IO),
	write(Result3, !IO),
	nl(!IO),
	nl(!IO),
	write_xml_doc_general_cc(StdOut, wrap(Map), simple,
		with_stylesheet("text/css",
		"http://www.cs.mu.oz.au/a_css.css"), embed_dtd, Result3_1,
		!IO),
	write_string("Result 3_1:\n", !IO),
	write(Result3_1, !IO),
	nl(!IO),
	nl(!IO),
	array.from_list([listPart(1),listPart(2),
		nothing,
		listPart(4),
		nothing,
		listPart(6),
		listPart(7),
		listPart(8),
		nothing], A2),
	write_xml_doc_general(StdOut, A2, unique, with_stylesheet("text/css",
		"http://www.cs.mu.oz.au/a_css.css"), embed_dtd, Result4, !IO),
	write_string("Result 4:\n", !IO),
	write(Result4, !IO),
	nl(!IO),
	nl(!IO),
	write_xml_doc_general(StdOut, X, simple, no_stylesheet,
		external_dtd(public_system("test", "test.dtd")), Result5, !IO),
	write_string("Result 5:\n", !IO),
	write(Result5, !IO),
	nl(!IO),
	nl(!IO),
	Simple = listPart(666),
	write_xml_doc_general(StdOut, Simple, custom(p1), no_stylesheet,
		external_dtd(system("test")), Result6, !IO),
	write_string("Result 6:\n", !IO),
	write(Result6, !IO),
	nl(!IO),
	nl(!IO),
	write_xml_doc_general(StdOut, wrap(Simple), custom(p1), no_stylesheet,
		embed_dtd, Result7, !IO),
	write_string("Result 7:\n", !IO),
	write(Result7, !IO),
	nl(!IO),
	nl(!IO),
	write_xml_doc_general_cc(StdOut, yes, unique, no_stylesheet, embed_dtd,
		Result8, !IO),
	write_string("Result 8:\n", !IO),
	write(Result8, !IO),
	nl(!IO),
	nl(!IO),
	write_xml_doc_general_cc(StdOut, 'new ext'(1), unique, no_stylesheet,
		no_dtd, Result9, !IO),
	write_string("Result 9:\n", !IO),
	write(Result9, !IO),
	nl(!IO),
	nl(!IO),
	write_xml_doc_general_cc(StdOut, 'new ext'(1), unique, no_stylesheet,
		embed_dtd, Result10, !IO),
	write_string("Result 10:\n", !IO),
	write(Result10, !IO),
	nl(!IO).