[m-rev.] Converting univ values to strings

Ralph Becket rafe at cs.mu.OZ.AU
Thu Jul 17 15:53:39 AEST 2003


I've moved the functionality to string.m as per Fergus' suggestion.
The new functions now work on arbitrary values, not just univs.

I've included the complete diff as the interdiff is nearly as long.  The
only real difference apart from the code movement is doing away with the
univ-centricity of the code.

Estimated hours taken: 6
Branches: main

Change the code to print the contents of a univ from io.m to code to turn
the contents of an arbitrary value into a string in string.m.

The main motivation for this change is that it has always been awkward to
swap between io.format etc. and io.print when including arbitrary values in
printed output.  With the new change, all such formatted output can be
done via io.format.

library/io.m:
	Move the code for io__do_write_univ etc. to string.m.
	Change io__do_write_univ to use the string.m code instead.

library/string.m:
	Added functions string/1, string/2 and the predicate string/4 to
	construct string representations of arbitrary values.

library/term_io.m:
	Added function term_io__quoted_char/1.

NEWS:
	Mention the new additions to the library.


Index: NEWS
===================================================================
RCS file: /home/mercury1/repository/mercury/NEWS,v
retrieving revision 1.314
diff -u -r1.314 NEWS
--- NEWS	26 May 2003 10:05:13 -0000	1.314
+++ NEWS	17 Jul 2003 05:48:22 -0000
@@ -26,7 +26,10 @@
   concatenation.
 * Several new functions have been added to the string module, namely
   elem/2, unsafe_elem/2, chomp/1, lstrip/1, lstrip/2, rstrip/1, rstrip/2,
-  strip/1, prefix_length/2, and suffix_length/2.
+  strip/1, prefix_length/2, suffix_length/2, string/1, string/2 and the
+  predicate string/4.
+* A new function has been added to the term_io module, namely
+  quoted_char.
 
 Portability improvements:
 * Nothing yet.
@@ -87,7 +90,10 @@
 
 * Several new functions have been added to the string module, namely
   elem/2, unsafe_elem/2, chomp/1, lstrip/1, lstrip/2, rstrip/1, rstrip/2,
-  strip/1, prefix_length/2, and suffix_length/2.
+  strip/1, prefix_length/2, suffix_length/2, string/1, string/2 and the
+  predicate string/4.
+
+* A new function quoted_char/1 has been added to the term_io module.
 
 * We've added a new library module, `array2d'.
 
Index: library/io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/io.m,v
retrieving revision 1.298
diff -u -r1.298 io.m
--- library/io.m	29 May 2003 12:08:25 -0000	1.298
+++ library/io.m	17 Jul 2003 02:22:02 -0000
@@ -2509,7 +2509,8 @@
 	; { univ_to_type(Univ, Char) } ->
 		io__write_char(Char)
 	; { univ_to_type(Univ, OrigUniv) } ->
-		io__write_univ(OrigUniv)
+		io__get_op_table(OpsTable),
+		io__write_string(string(OpsTable, univ_value(OrigUniv)))
 	;
 		io__print_quoted(NonCanon, Term)
 	).
@@ -2562,8 +2563,7 @@
 :- mode io__do_write(in, in, di, uo) is cc_multi.
 
 io__do_write(NonCanon, Term) -->
-	{ type_to_univ(Term, Univ) },
-	io__do_write_univ(NonCanon, Univ).
+	io__do_write_univ(NonCanon, univ(Term)).
 
 %-----------------------------------------------------------------------------%
 
@@ -2590,340 +2590,9 @@
 :- mode io__do_write_univ(in, in, di, uo) is cc_multi.
 
 io__do_write_univ(NonCanon, Univ) -->
-	io__get_op_table(OpTable),
-	io__do_write_univ(NonCanon, Univ, ops__max_priority(OpTable) + 1).
-
-:- pred io__do_write_univ(deconstruct__noncanon_handling, univ, ops__priority,
-	io__state, io__state).
-:- mode io__do_write_univ(in(do_not_allow), in, in, di, uo) is det.
-:- mode io__do_write_univ(in(canonicalize), in, in, di, uo) is det.
-:- mode io__do_write_univ(in(include_details_cc), in, in, di, uo) is cc_multi.
-:- mode io__do_write_univ(in, in, in, di, uo) is cc_multi.
-
-io__do_write_univ(NonCanon, Univ, Priority) -->
-	%
-	% we need to special-case the builtin types:
-	%	int, char, float, string
-	%	type_info, univ, c_pointer, array
-	%	and private_builtin:type_info
-	%
-	( { univ_to_type(Univ, String) } ->
-		term_io__quote_string(String)
-	; { univ_to_type(Univ, Char) } ->
-		term_io__quote_char(Char)
-	; { univ_to_type(Univ, Int) } ->
-		io__write_int(Int)
-	; { univ_to_type(Univ, Float) } ->
-		io__write_float(Float)
-	; { univ_to_type(Univ, TypeDesc) } ->
-		io__write_type_desc(TypeDesc)
-	; { univ_to_type(Univ, TypeCtorDesc) } ->
-		io__write_type_ctor_desc(TypeCtorDesc)
-	; { univ_to_type(Univ, C_Pointer) } ->
-		io__write_c_pointer(C_Pointer)
-	;
-		%
-		% Check if the type is array:array/1.
-		% We can't just use univ_to_type here since 
-		% array:array/1 is a polymorphic type.
-		%
-		% The calls to type_ctor_name and type_ctor_module_name
-		% are not really necessary -- we could use univ_to_type
-		% in the condition instead of det_univ_to_type in the body.
-		% However, this way of doing things is probably more efficient
-		% in the common case when the thing being printed is
-		% *not* of type array:array/1.
-		%
-		% The ordering of the tests here (arity, then name, then
-		% module name, rather than the reverse) is also chosen
-		% for efficiency, to find failure cheaply in the common cases,
-		% rather than for readability.
-		%
-		{ type_ctor_and_args(univ_type(Univ), TypeCtor, ArgTypes) },
-		{ ArgTypes = [ElemType] },
-		{ type_ctor_name(TypeCtor) = "array" },
-		{ type_ctor_module_name(TypeCtor) = "array" }
-	->
-		%
-		% Now that we know the element type, we can
-		% constrain the type of the variable `Array'
-		% so that we can use det_univ_to_type.
-		%
-		{ has_type(Elem, ElemType) },
-		{ same_array_elem_type(Array, Elem) },
-		{ det_univ_to_type(Univ, Array) },
-		io__write_array(Array)
-	; 
-		%
-		% Check if the type is private_builtin:type_info/1.
-		% See the comments above for array:array/1.
-		%
-		{ type_ctor_and_args(univ_type(Univ), TypeCtor, ArgTypes) },
-		{ ArgTypes = [ElemType] },
-		{ type_ctor_name(TypeCtor) = "type_info" },
-		{ type_ctor_module_name(TypeCtor) = "private_builtin" }
-	->
-		{ has_type(Elem, ElemType) },
-		{ same_private_builtin_type(PrivateBuiltinTypeInfo, Elem) },
-		{ det_univ_to_type(Univ, PrivateBuiltinTypeInfo) },
-		io__write_private_builtin_type_info(PrivateBuiltinTypeInfo)
-	; 
-		io__write_ordinary_term(NonCanon, Univ, Priority)
-	).
-
-:- pred same_array_elem_type(array(T), T).
-:- mode same_array_elem_type(unused, unused) is det.
-same_array_elem_type(_, _).
-
-:- pred same_private_builtin_type(private_builtin__type_info(T), T).
-:- mode same_private_builtin_type(unused, unused) is det.
-same_private_builtin_type(_, _).
-
-:- pred io__write_ordinary_term(deconstruct__noncanon_handling, univ,
-	ops__priority, io__state, io__state).
-:- mode io__write_ordinary_term(in(do_not_allow), in, in, di, uo) is det.
-:- mode io__write_ordinary_term(in(canonicalize), in, in, di, uo) is det.
-:- mode io__write_ordinary_term(in(include_details_cc), in, in, di, uo)
-	is cc_multi.
-:- mode io__write_ordinary_term(in, in, in, di, uo) is cc_multi.
-
-io__write_ordinary_term(NonCanon, Univ, Priority) -->
-	{ univ_value(Univ) = Term },
-	{ deconstruct__deconstruct(Term, NonCanon, Functor, _Arity, Args) },
-	io__get_op_table(OpTable),
-	(
-		{ Functor = "[|]" },
-		{ Args = [ListHead, ListTail] }
-	->
-		io__write_char('['),
-		io__write_arg(NonCanon, ListHead),
-		io__write_list_tail(NonCanon, ListTail),
-		io__write_char(']')
-	;
-		{ Functor = "[]" },
-		{ Args = [] }
-	->
-		io__write_string("[]")
-	;
-		{ Functor = "{}" },
-		{ Args = [BracedTerm] }
-	->
-		io__write_string("{ "),
-		io__do_write_univ(NonCanon, BracedTerm),
-		io__write_string(" }")
-	;
-		{ Functor = "{}" },
-		{ Args = [BracedHead | BracedTail] }
-	->
-		io__write_char('{'),
-		io__write_arg(NonCanon, BracedHead),
-		io__write_term_args(NonCanon, BracedTail),
-		io__write_char('}')
-	;
-		{ Args = [PrefixArg] },
-		{ ops__lookup_prefix_op(OpTable, Functor,
-			OpPriority, OpAssoc) }
-	->
-		maybe_write_char('(', Priority, OpPriority),
-		term_io__quote_atom(Functor),
-		io__write_char(' '),
-		{ adjust_priority(OpPriority, OpAssoc, NewPriority) },
-		io__do_write_univ(NonCanon, PrefixArg, NewPriority),
-		maybe_write_char(')', Priority, OpPriority)
-	;
-		{ Args = [PostfixArg] },
-		{ ops__lookup_postfix_op(OpTable, Functor,
-			OpPriority, OpAssoc) }
-	->
-		maybe_write_char('(', Priority, OpPriority),
-		{ adjust_priority(OpPriority, OpAssoc, NewPriority) },
-		io__do_write_univ(NonCanon, PostfixArg, NewPriority),
-		io__write_char(' '),
-		term_io__quote_atom(Functor),
-		maybe_write_char(')', Priority, OpPriority)
-	;
-		{ Args = [Arg1, Arg2] },
-		{ ops__lookup_infix_op(OpTable, Functor, 
-			OpPriority, LeftAssoc, RightAssoc) }
-	->
-		maybe_write_char('(', Priority, OpPriority),
-		{ adjust_priority(OpPriority, LeftAssoc, LeftPriority) },
-		io__do_write_univ(NonCanon, Arg1, LeftPriority),
-		( { Functor = "," } ->
-			io__write_string(", ")
-		;
-			io__write_char(' '),
-			term_io__quote_atom(Functor),
-			io__write_char(' ')
-		),
-		{ adjust_priority(OpPriority, RightAssoc, RightPriority) },
-		io__do_write_univ(NonCanon, Arg2, RightPriority),
-		maybe_write_char(')', Priority, OpPriority)
-	;
-		{ Args = [Arg1, Arg2] },
-		{ ops__lookup_binary_prefix_op(OpTable, Functor,
-			OpPriority, FirstAssoc, SecondAssoc) }
-	->
-		maybe_write_char('(', Priority, OpPriority),
-		term_io__quote_atom(Functor),
-		io__write_char(' '),
-		{ adjust_priority(OpPriority, FirstAssoc, FirstPriority) },
-		io__do_write_univ(NonCanon, Arg1, FirstPriority),
-		io__write_char(' '),
-		{ adjust_priority(OpPriority, SecondAssoc, SecondPriority) },
-		io__do_write_univ(NonCanon, Arg2, SecondPriority),
-		maybe_write_char(')', Priority, OpPriority)
-	;
-		(
-			{ Args = [] },
-			{ ops__lookup_op(OpTable, Functor) },
-			{ Priority =< ops__max_priority(OpTable) }
-		->
-			io__write_char('('),
-			term_io__quote_atom(Functor),
-			io__write_char(')')
-		;
-			term_io__quote_atom(Functor,
-				maybe_adjacent_to_graphic_token)
-		),
-		(
-			{ Args = [X|Xs] }
-		->
-			io__write_char('('),
-			io__write_arg(NonCanon, X),
-			io__write_term_args(NonCanon, Xs),
-			io__write_char(')')
-		;
-			[]
-		)
-	).
-
-:- pred maybe_write_char(char, ops__priority, ops__priority,
-			io__state, io__state).
-:- mode maybe_write_char(in, in, in, di, uo) is det.
-
-maybe_write_char(Char, Priority, OpPriority) -->
-	( { OpPriority > Priority } ->
-		io__write_char(Char)
-	;
-		[]
-	).
-
-:- pred adjust_priority(ops__priority, ops__assoc, ops__priority).
-:- mode adjust_priority(in, in, out) is det.
-
-adjust_priority(Priority, y, Priority).
-adjust_priority(Priority, x, Priority - 1).
-
-:- pred io__write_list_tail(deconstruct__noncanon_handling, univ,
-	io__state, io__state).
-:- mode io__write_list_tail(in(do_not_allow), in, di, uo) is det.
-:- mode io__write_list_tail(in(canonicalize), in, di, uo) is det.
-:- mode io__write_list_tail(in(include_details_cc), in, di, uo) is cc_multi.
-:- mode io__write_list_tail(in, in, di, uo) is cc_multi.
-
-io__write_list_tail(NonCanon, Univ) -->
-	{ Term = univ_value(Univ) },
-	{ deconstruct__deconstruct(Term, NonCanon, Functor, _Arity, Args) },
-	( { Functor = "[|]", Args = [ListHead, ListTail] } ->
-		io__write_string(", "),
-		io__write_arg(NonCanon, ListHead),
-		io__write_list_tail(NonCanon, ListTail)
-	; { Functor = "[]", Args = [] } ->
-		[]
-	;
-		io__write_string(" | "),
-		io__do_write_univ(NonCanon, Univ)
-	).
-
-:- pred io__write_term_args(deconstruct__noncanon_handling, list(univ),
-	io__state, io__state).
-:- mode io__write_term_args(in(do_not_allow), in, di, uo) is det.
-:- mode io__write_term_args(in(canonicalize), in, di, uo) is det.
-:- mode io__write_term_args(in(include_details_cc), in, di, uo) is cc_multi.
-:- mode io__write_term_args(in, in, di, uo) is cc_multi.
-
-	% write the remaining arguments
-io__write_term_args(_, []) --> [].
-io__write_term_args(NonCanon, [X|Xs]) -->
-	io__write_string(", "),
-	io__write_arg(NonCanon, X),
-	io__write_term_args(NonCanon, Xs).
-
-:- pred io__write_arg(deconstruct__noncanon_handling, univ,
-	io__state, io__state).
-:- mode io__write_arg(in(do_not_allow), in, di, uo) is det.
-:- mode io__write_arg(in(canonicalize), in, di, uo) is det.
-:- mode io__write_arg(in(include_details_cc), in, di, uo) is cc_multi.
-:- mode io__write_arg(in, in, di, uo) is cc_multi.
-
-io__write_arg(NonCanon, X) -->
-	arg_priority(ArgPriority),
-	io__do_write_univ(NonCanon, X, ArgPriority).
-
-:- pred arg_priority(int, io__state, io__state).
-:- mode arg_priority(out, di, uo) is det.
-/*
-arg_priority(ArgPriority) -->
-	io__get_op_table(OpTable),
-	{ ops__lookup_infix_op(OpTable, ",", Priority, _, _) ->
-		ArgPriority = Priority }
-	;
-		error("arg_priority: can't find the priority of `,'")
-	}.
-*/
-% We could implement this as above, but it's more efficient to just
-% hard-code it.
-arg_priority(1000) --> [].
-
-%-----------------------------------------------------------------------------%
-
-:- pred io__write_type_desc(type_desc, io__state, io__state).
-:- mode io__write_type_desc(in, di, uo) is det.
-
-io__write_type_desc(TypeDesc) -->
-	io__write_string(type_name(TypeDesc)).
-
-:- pred io__write_type_ctor_desc(type_ctor_desc, io__state, io__state).
-:- mode io__write_type_ctor_desc(in, di, uo) is det.
-
-io__write_type_ctor_desc(TypeCtorDesc) -->
-        { type_ctor_name_and_arity(TypeCtorDesc, ModuleName, Name, Arity0) },
-	{ ModuleName = "builtin", Name = "func" ->
-		% The type ctor that we call `builtin:func/N' takes N + 1
-		% type parameters: N arguments plus one return value.
-		% So we need to subtract one from the arity here.
-		Arity = Arity0 - 1
-	;
-		Arity = Arity0
-	},
-	( { ModuleName = "builtin" } ->
-		io__format("%s/%d", [s(Name), i(Arity)])
-	;
-		io__format("%s.%s/%d", [s(ModuleName), s(Name), i(Arity)])
-	).
-
-:- pred io__write_c_pointer(c_pointer, io__state, io__state).
-:- mode io__write_c_pointer(in, di, uo) is det.
-
-io__write_c_pointer(_C_Pointer) -->
-	% XXX what should we do here?
-	io__write_string("'<<c_pointer>>'").
-
-:- pred io__write_array(array(T), io__state, io__state).
-:- mode io__write_array(in, di, uo) is det.
-
-io__write_array(Array) -->
-	io__write_string("array("),
-	{ array__to_list(Array, List) },
-	io__write(List),
-	io__write_string(")").
-
-:- pred io__write_private_builtin_type_info(private_builtin__type_info(T)::in,
-		io__state::di, io__state::uo) is det.
-io__write_private_builtin_type_info(PrivateBuiltinTypeInfo) -->
-	{ TypeInfo = rtti_implementation__unsafe_cast(PrivateBuiltinTypeInfo) },
-	io__write_type_desc(TypeInfo).
+	io__get_op_table(OpsTable),
+	{ string(NonCanon, OpsTable, Univ, String) },
+	io__write_string(String).
 
 %-----------------------------------------------------------------------------%
 
Index: library/std_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.284
diff -u -r1.284 std_util.m
--- library/std_util.m	14 May 2003 14:38:47 -0000	1.284
+++ library/std_util.m	17 Jul 2003 02:39:43 -0000
@@ -18,7 +18,7 @@
 
 :- interface.
 
-:- import_module list, set, bool.
+:- import_module list, set, bool, string.
 :- import_module type_desc.
 
 %-----------------------------------------------------------------------------%
@@ -735,7 +735,7 @@
 
 :- implementation.
 
-:- import_module require, set, int, string, bool.
+:- import_module require, set, int, string, bool, char, array.
 :- import_module construct, deconstruct.
 :- use_module private_builtin. % for the `heap_pointer' type.
 
@@ -1696,5 +1696,5 @@
 	aggregate(P, (pred(X::in, A0::in, A::out) is det :- A = F(X, A0)),
 		Acc0, Acc).
 
-%------------------------------------------------------------------------------%
-%------------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: library/string.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/string.m,v
retrieving revision 1.203
diff -u -r1.203 string.m
--- library/string.m	5 Jun 2003 05:26:34 -0000	1.203
+++ library/string.m	17 Jul 2003 02:40:56 -0000
@@ -20,6 +20,8 @@
 
 :- interface.
 :- import_module list, char.
+:- import_module deconstruct.
+:- import_module ops.
 
 :- func string__length(string) = int.
 :- mode string__length(in) = uo is det.
@@ -69,6 +71,32 @@
 	% string__suffix(String, Suffix) is true iff Suffix is a
 	% suffix of String.  Same as string__append(_, Suffix, String).
 
+:- func string__string(T) = string.
+	% string__string(X): Returns a canonicalized string representation of
+	% the object X using the standard Mercury operators.
+
+:- func string__string(ops__table, T) = string.
+	%
+	% As above, but using the supplied table of operators.
+
+:- pred string__string(deconstruct__noncanon_handling, ops__table, T, string).
+:- mode string__string(in(do_not_allow), in, in, out) is det.
+:- mode string__string(in(canonicalize), in, in, out) is det.
+:- mode string__string(in(include_details_cc), in, in, out) is cc_multi.
+:- mode string__string(in, in, in, out) is cc_multi.
+%	string__string(NonCanon, OpsTable, X, String)
+%
+%	As above, but the caller specifies what behaviour should
+%	occur for non-canonical terms (i.e. terms where multiple
+%	representations may compare as equal):
+%	- `do_not_allow' will throw an exception if (any subterm of)
+%	   the argument is not canonical;
+%	- `canonicalize' will substitute a string indicating the
+%	   presence of a non-canonical subterm;
+%	- `include_details_cc' will show the structure of any
+%	   non-canonical subterms, but can only be called from a
+%	   committed choice context.
+
 :- func string__char_to_string(char) = string.
 :- mode string__char_to_string(in) = uo is det.
 :- pred string__char_to_string(char, string).
@@ -577,7 +605,8 @@
 %-----------------------------------------------------------------------------%
 
 :- implementation.
-:- import_module bool, integer, std_util, int, float, require.
+:- import_module bool, integer, std_util, int, float, array, require.
+:- use_module term_io, type_desc, rtti_implementation.
 
 :- pred string__to_int_list(string, list(int)).
 :- mode string__to_int_list(in, out) is det.
@@ -1354,7 +1383,7 @@
 		error("string__format: format string invalid.")
 	).
 
-:- type specifier
+:- type string__specifier
 	--->	conv(
 			flags 		:: list(char),
 			width		:: maybe(list(char)),
@@ -1368,7 +1397,7 @@
 	% We alternate between the list of characters which don't
 	% represent a conversion specifier and those that do.
 	%
-:- pred format_string(list(specifier)::out,
+:- pred format_string(list(string__specifier)::out,
 		list(string__poly_type)::in, list(string__poly_type)::out,
 		list(char)::in, list(char)::out) is det.
 
@@ -1403,7 +1432,7 @@
 	% may be (in this order)  zero  or more  flags,  an optional
 	% minimum field width, and an optional precision.
 	%
-:- pred conversion_specification(specifier::out,
+:- pred conversion_specification(string__specifier::out,
 		list(string__poly_type)::in, list(string__poly_type)::out,
 		list(char)::in, list(char)::out) is semidet.
 
@@ -1601,7 +1630,7 @@
 		[]
 	).
 
-:- func specifier_to_string(specifier) = string. 
+:- func specifier_to_string(string__specifier) = string. 
 
 specifier_to_string(conv(Flags, Width, Prec, Spec)) = String :-
 	(
@@ -3930,6 +3959,445 @@
 	).
 
 %------------------------------------------------------------------------------%
+
+	% For efficiency, these predicates collect a list of strings
+	% which, when concatenated in reverse order, produce the final
+	% output.
+	%
+:- type revstrings == list(string).
+
+	% Utility predicate.
+	%
+:- pred add_revstring(string, revstrings, revstrings).
+:- mode add_revstring(in,     in,         out       ) is det.
+
+add_revstring(String, RevStrings, [String | RevStrings]).
+
+
+
+% various different versions of univ_to_string.
+
+string__string(Univ) = String :-
+	string__string(canonicalize, ops__init_mercury_op_table, Univ, String).
+
+string__string(OpsTable, Univ) = String :-
+	string__string(canonicalize, OpsTable, Univ, String).
+
+
+
+string__string(NonCanon, OpsTable, Univ, String) :-
+	value_to_revstrings(NonCanon, OpsTable, Univ, [], RevStrings),
+	String = string__append_list(list__reverse(RevStrings)).
+
+
+
+:- pred value_to_revstrings(deconstruct__noncanon_handling,
+	ops__table, T, revstrings, revstrings).
+:- mode value_to_revstrings(in(do_not_allow), in, in, in, out) is det.
+:- mode value_to_revstrings(in(canonicalize), in, in, in, out) is det.
+:- mode value_to_revstrings(in(include_details_cc), in, in, in, out)
+	is cc_multi.
+:- mode value_to_revstrings(in, in, in, in, out)
+	is cc_multi.
+
+value_to_revstrings(NonCanon, OpsTable, Univ, !Rs) :-
+	Priority = ops__max_priority(OpsTable) + 1,
+	value_to_revstrings(NonCanon, OpsTable, Priority, Univ, !Rs).
+
+
+
+:- pred value_to_revstrings(deconstruct__noncanon_handling,
+	ops__table, ops__priority, T, revstrings, revstrings).
+:- mode value_to_revstrings(in(do_not_allow), in, in, in, in, out) is det.
+:- mode value_to_revstrings(in(canonicalize), in, in, in, in, out) is det.
+:- mode value_to_revstrings(in(include_details_cc), in, in, in, in, out)
+	is cc_multi.
+:- mode value_to_revstrings(in, in, in, in, in, out)
+	is cc_multi.
+
+value_to_revstrings(NonCanon, OpsTable, Priority, X, !Rs) :-
+	%
+	% we need to special-case the builtin types:
+	%	int, char, float, string
+	%	type_info, univ, c_pointer, array
+	%	and private_builtin:type_info
+	%
+	( dynamic_cast(X, String) ->
+		add_revstring(term_io__quoted_string(String), !Rs)
+	; dynamic_cast(X, Char) ->
+		add_revstring(term_io__quoted_char(Char), !Rs)
+	; dynamic_cast(X, Int) ->
+		add_revstring(string__int_to_string(Int), !Rs)
+	; dynamic_cast(X, Float) ->
+		add_revstring(string__float_to_string(Float), !Rs)
+	; dynamic_cast(X, TypeDesc) ->
+		type_desc_to_revstrings(TypeDesc, !Rs)
+	; dynamic_cast(X, TypeCtorDesc) ->
+		type_ctor_desc_to_revstrings(TypeCtorDesc, !Rs)
+	; dynamic_cast(X, C_Pointer) ->
+		add_revstring(c_pointer_to_string(C_Pointer), !Rs)
+	;
+		%
+		% Check if the type is array:array/1.
+		% We can't just use dynamic_cast here since 
+		% array:array/1 is a polymorphic type.
+		%
+		% The calls to type_ctor_name and type_ctor_module_name
+		% are not really necessary -- we could use dynamic_cast
+		% in the condition instead of det_dynamic_cast in the body.
+		% However, this way of doing things is probably more efficient
+		% in the common case when the thing being printed is
+		% *not* of type array:array/1.
+		%
+		% The ordering of the tests here (arity, then name, then
+		% module name, rather than the reverse) is also chosen
+		% for efficiency, to find failure cheaply in the common cases,
+		% rather than for readability.
+		%
+		type_desc__type_ctor_and_args(type_of(X), TypeCtor, ArgTypes),
+		ArgTypes = [ElemType],
+		type_desc__type_ctor_name(TypeCtor) = "array",
+		type_desc__type_ctor_module_name(TypeCtor) = "array"
+	->
+		%
+		% Now that we know the element type, we can
+		% constrain the type of the variable `Array'
+		% so that we can use det_dynamic_cast.
+		%
+		type_desc__has_type(Elem, ElemType),
+		same_array_elem_type(Array, Elem),
+		det_dynamic_cast(X, Array),
+		array_to_revstrings(NonCanon, OpsTable, Array, !Rs)
+	; 
+		%
+		% Check if the type is private_builtin:type_info/1.
+		% See the comments above for array:array/1.
+		%
+		type_desc__type_ctor_and_args(type_of(X), TypeCtor, ArgTypes),
+		ArgTypes = [ElemType],
+		type_desc__type_ctor_name(TypeCtor) = "type_info",
+		type_desc__type_ctor_module_name(TypeCtor) = "private_builtin"
+	->
+		type_desc__has_type(Elem, ElemType),
+		same_private_builtin_type(PrivateBuiltinTypeInfo, Elem),
+		det_dynamic_cast(X, PrivateBuiltinTypeInfo),
+		private_builtin_type_info_to_revstrings(
+			PrivateBuiltinTypeInfo, !Rs)
+	; 
+		ordinary_term_to_revstrings(NonCanon, OpsTable, Priority,
+			X, !Rs)
+	).
+
+
+
+:- pred same_array_elem_type(array(T), T).
+:- mode same_array_elem_type(unused, unused) is det.
+same_array_elem_type(_, _).
+
+
+
+:- pred same_private_builtin_type(private_builtin__type_info(T), T).
+:- mode same_private_builtin_type(unused, unused) is det.
+same_private_builtin_type(_, _).
+
+
+
+:- pred ordinary_term_to_revstrings(deconstruct__noncanon_handling,
+	ops__table, ops__priority, T, revstrings, revstrings).
+:- mode ordinary_term_to_revstrings(in(do_not_allow), in, in, in, in, out)
+	is det.
+:- mode ordinary_term_to_revstrings(in(canonicalize), in, in, in, in, out)
+	is det.
+:- mode ordinary_term_to_revstrings(in(include_details_cc), in, in, in, in, out)
+	is cc_multi.
+:- mode ordinary_term_to_revstrings(in, in, in, in, in, out)
+	is cc_multi.
+
+ordinary_term_to_revstrings(NonCanon, OpsTable, Priority, X, !Rs) :-
+	deconstruct__deconstruct(X, NonCanon, Functor, _Arity, Args),
+	(
+		Functor = "[|]",
+		Args = [ListHead, ListTail]
+	->
+		add_revstring("[", !Rs),
+		arg_to_revstrings(NonCanon, OpsTable, ListHead, !Rs),
+		list_tail_to_revstrings(NonCanon, OpsTable, ListTail, !Rs),
+		add_revstring("]", !Rs)
+	;
+		Functor = "[]",
+		Args = []
+	->
+		add_revstring("[]", !Rs)
+	;
+		Functor = "{}",
+		Args = [BracedTerm]
+	->
+		add_revstring("{ ", !Rs),
+		value_to_revstrings(NonCanon, OpsTable, BracedTerm, !Rs),
+		add_revstring(" }", !Rs)
+	;
+		Functor = "{}",
+		Args = [BracedHead | BracedTail]
+	->
+		add_revstring("{", !Rs),
+		arg_to_revstrings(NonCanon, OpsTable, BracedHead, !Rs),
+		term_args_to_revstrings(NonCanon, OpsTable, BracedTail, !Rs),
+		add_revstring("}", !Rs)
+	;
+		Args = [PrefixArg],
+		ops__lookup_prefix_op(OpsTable, Functor,
+			OpPriority, OpAssoc)
+	->
+		maybe_add_revstring("(", Priority, OpPriority, !Rs),
+		add_revstring(term_io__quoted_atom(Functor), !Rs),
+		add_revstring(" ", !Rs),
+		adjust_priority(OpPriority, OpAssoc, NewPriority),
+		value_to_revstrings(NonCanon, OpsTable, NewPriority,
+			PrefixArg, !Rs),
+		maybe_add_revstring(")", Priority, OpPriority, !Rs)
+	;
+		Args = [PostfixArg],
+		ops__lookup_postfix_op(OpsTable, Functor,
+			OpPriority, OpAssoc)
+	->
+		maybe_add_revstring("(", Priority, OpPriority, !Rs),
+		adjust_priority(OpPriority, OpAssoc, NewPriority),
+		value_to_revstrings(NonCanon, OpsTable, NewPriority,
+			PostfixArg, !Rs),
+		add_revstring(" ", !Rs),
+		add_revstring(term_io__quoted_atom(Functor), !Rs),
+		maybe_add_revstring(")", Priority, OpPriority, !Rs)
+	;
+		Args = [Arg1, Arg2],
+		ops__lookup_infix_op(OpsTable, Functor, 
+			OpPriority, LeftAssoc, RightAssoc)
+	->
+		maybe_add_revstring("(", Priority, OpPriority, !Rs),
+		adjust_priority(OpPriority, LeftAssoc, LeftPriority),
+		value_to_revstrings(NonCanon, OpsTable, LeftPriority, Arg1, !Rs),
+		( Functor = "," ->
+			add_revstring(", ", !Rs)
+		;
+			add_revstring(" ", !Rs),
+			add_revstring(term_io__quoted_atom(Functor), !Rs),
+			add_revstring(" ", !Rs)
+		),
+		adjust_priority(OpPriority, RightAssoc, RightPriority),
+		value_to_revstrings(NonCanon, OpsTable, RightPriority,
+			Arg2, !Rs),
+		maybe_add_revstring(")", Priority, OpPriority, !Rs)
+	;
+		Args = [Arg1, Arg2],
+		ops__lookup_binary_prefix_op(OpsTable, Functor,
+			OpPriority, FirstAssoc, SecondAssoc)
+	->
+		maybe_add_revstring("(", Priority, OpPriority, !Rs),
+		add_revstring(term_io__quoted_atom(Functor), !Rs),
+		add_revstring(" ", !Rs),
+		adjust_priority(OpPriority, FirstAssoc, FirstPriority),
+		value_to_revstrings(NonCanon, OpsTable, FirstPriority,
+			Arg1, !Rs),
+		add_revstring(" ", !Rs),
+		adjust_priority(OpPriority, SecondAssoc, SecondPriority),
+		value_to_revstrings(NonCanon, OpsTable, SecondPriority,
+			Arg2, !Rs),
+		maybe_add_revstring(")", Priority, OpPriority, !Rs)
+	;
+		(
+			Args = [],
+			ops__lookup_op(OpsTable, Functor),
+			Priority =< ops__max_priority(OpsTable)
+		->
+			add_revstring("(", !Rs),
+			add_revstring(term_io__quoted_atom(Functor), !Rs),
+			add_revstring(")", !Rs)
+		;
+			add_revstring(
+				term_io__quoted_atom(Functor,
+				    term_io__maybe_adjacent_to_graphic_token),
+				!Rs
+			)
+		),
+		(
+			Args = [Y | Ys]
+		->
+			add_revstring("(", !Rs),
+			arg_to_revstrings(NonCanon, OpsTable, Y, !Rs),
+			term_args_to_revstrings(NonCanon, OpsTable, Ys, !Rs),
+			add_revstring(")", !Rs)
+		;
+			true
+		)
+	).
+
+
+
+:- pred maybe_add_revstring(string, ops__priority, ops__priority,
+			revstrings, revstrings).
+:- mode maybe_add_revstring(in, in, in, in, out) is det.
+
+maybe_add_revstring(String, Priority, OpPriority, !Rs) :-
+	( OpPriority > Priority ->
+		add_revstring(String, !Rs)
+	;
+		true
+	).
+
+
+
+:- pred adjust_priority(ops__priority, ops__assoc, ops__priority).
+:- mode adjust_priority(in, in, out) is det.
+
+adjust_priority(Priority, ops__y, Priority).
+adjust_priority(Priority, ops__x, Priority - 1).
+
+
+
+:- pred list_tail_to_revstrings(deconstruct__noncanon_handling,
+	ops__table, T, revstrings, revstrings).
+:- mode list_tail_to_revstrings(in(do_not_allow), in, in, in, out) is det.
+:- mode list_tail_to_revstrings(in(canonicalize), in, in, in, out) is det.
+:- mode list_tail_to_revstrings(in(include_details_cc), in, in, in, out)
+	is cc_multi.
+:- mode list_tail_to_revstrings(in, in, in, in, out) is cc_multi.
+
+list_tail_to_revstrings(NonCanon, OpsTable, X, !Rs) :-
+	deconstruct__deconstruct(X, NonCanon, Functor, _Arity, Args),
+	( Functor = "[|]", Args = [ListHead, ListTail] ->
+		add_revstring(", ", !Rs),
+		arg_to_revstrings(NonCanon, OpsTable, ListHead, !Rs),
+		list_tail_to_revstrings(NonCanon, OpsTable, ListTail, !Rs)
+	; Functor = "[]", Args = [] ->
+		true
+	;
+		add_revstring(" | ", !Rs),
+		value_to_revstrings(NonCanon, OpsTable, X, !Rs)
+	).
+
+
+
+:- pred term_args_to_revstrings(deconstruct__noncanon_handling,
+	ops__table, list(T), revstrings, revstrings).
+:- mode term_args_to_revstrings(in(do_not_allow), in, in, in, out) is det.
+:- mode term_args_to_revstrings(in(canonicalize), in, in, in, out) is det.
+:- mode term_args_to_revstrings(in(include_details_cc), in, in, in, out)
+	is cc_multi.
+:- mode term_args_to_revstrings(in, in, in, in, out) is cc_multi.
+
+	% write the remaining arguments
+term_args_to_revstrings(_, _, [], !Rs).
+term_args_to_revstrings(NonCanon, OpsTable, [X|Xs], !Rs) :-
+	add_revstring(", ", !Rs),
+	arg_to_revstrings(NonCanon, OpsTable, X, !Rs),
+	term_args_to_revstrings(NonCanon, OpsTable, Xs, !Rs).
+
+
+
+:- pred arg_to_revstrings(deconstruct__noncanon_handling,
+	ops__table, T, revstrings, revstrings).
+:- mode arg_to_revstrings(in(do_not_allow), in, in, in, out) is det.
+:- mode arg_to_revstrings(in(canonicalize), in, in, in, out) is det.
+:- mode arg_to_revstrings(in(include_details_cc), in, in, in, out) is cc_multi.
+:- mode arg_to_revstrings(in, in, in, in, out) is cc_multi.
+
+arg_to_revstrings(NonCanon, OpsTable, X, !Rs) :-
+	Priority = comma_priority(OpsTable),
+	value_to_revstrings(NonCanon, OpsTable, Priority, X, !Rs).
+
+
+
+:- func comma_priority(ops__table) = ops__priority.
+/*
+comma_priority(OpsTable) =
+	( if ops__lookup_infix_op(OpTable, ",", Priority, _, _) then
+		Priority
+	  else
+		func_error("arg_priority: can't find the priority of `,'")
+	).
+*/
+% We could implement this as above, but it's more efficient to just
+% hard-code it.
+comma_priority(_OpTable) = 1000.
+
+
+
+:- func c_pointer_to_string(c_pointer) = string.
+
+c_pointer_to_string(_C_Pointer) = "<<c_pointer>>".
+
+
+
+:- pred array_to_revstrings(deconstruct__noncanon_handling,
+	ops__table, array(T), revstrings, revstrings).
+:- mode array_to_revstrings(in(do_not_allow), in, in, in, out) is det.
+:- mode array_to_revstrings(in(canonicalize), in, in, in, out) is det.
+:- mode array_to_revstrings(in(include_details_cc), in, in, in, out)
+	is cc_multi.
+:- mode array_to_revstrings(in, in, in, in, out)
+	is cc_multi.
+
+array_to_revstrings(NonCanon, OpsTable, Array, !Rs) :-
+	add_revstring("array(", !Rs),
+	value_to_revstrings(NonCanon, OpsTable,
+		array__to_list(Array) `with_type` list(T), !Rs),
+	add_revstring(")", !Rs).
+
+
+
+:- pred type_desc_to_revstrings(type_desc__type_desc, revstrings, revstrings).
+:- mode type_desc_to_revstrings(in, in, out) is det.
+
+type_desc_to_revstrings(TypeDesc, !Rs) :-
+	add_revstring(
+		term_io__quoted_atom(type_desc__type_name(TypeDesc)),
+		!Rs
+	).
+
+
+
+:- pred type_ctor_desc_to_revstrings(type_desc__type_ctor_desc,
+	revstrings, revstrings).
+:- mode type_ctor_desc_to_revstrings(in, in, out) is det.
+
+type_ctor_desc_to_revstrings(TypeCtorDesc, !Rs) :-
+        type_desc__type_ctor_name_and_arity(TypeCtorDesc,
+		ModuleName, Name0, Arity0),
+	Name = term_io__quoted_atom(Name0),
+	( ModuleName = "builtin", Name = "func" ->
+		% The type ctor that we call `builtin:func/N' takes N + 1
+		% type parameters: N arguments plus one return value.
+		% So we need to subtract one from the arity here.
+		Arity = Arity0 - 1
+	;
+		Arity = Arity0
+	),
+	( ModuleName = "builtin" ->
+		String = string__format("%s/%d", [s(Name), i(Arity)])
+	;
+		String = string__format("%s.%s/%d",
+			[s(ModuleName), s(Name), i(Arity)])
+	),
+	add_revstring(String, !Rs).
+
+
+
+:- pred private_builtin_type_info_to_revstrings(
+		private_builtin__type_info(T), revstrings, revstrings).
+:- mode private_builtin_type_info_to_revstrings(in, in, out) is det.
+
+private_builtin_type_info_to_revstrings(PrivateBuiltinTypeInfo, !Rs) :-
+	TypeDesc = rtti_implementation__unsafe_cast(PrivateBuiltinTypeInfo),
+	type_desc_to_revstrings(TypeDesc, !Rs).
+
+
+
+:- pred det_dynamic_cast(T1, T2).
+:- mode det_dynamic_cast(in, out) is det.
+
+det_dynamic_cast(X, Y) :-
+	det_univ_to_type(univ(X), Y).
+
+%-----------------------------------------------------------------------------%
 
 :- end_module string.
 
Index: library/term_io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/term_io.m,v
retrieving revision 1.67
diff -u -r1.67 term_io.m
--- library/term_io.m	26 May 2003 09:00:31 -0000	1.67
+++ library/term_io.m	15 Jul 2003 06:33:40 -0000
@@ -111,6 +111,9 @@
 	% Given a character C, write C in single-quotes,
 	% escaped if necessary, to stdout.
 
+:- func term_io__quoted_char(char) = string.
+	% Like term_io__quote_char, but return the result in a string.
+
 :- pred term_io__write_escaped_char(char, io__state, io__state).
 :- mode term_io__write_escaped_char(in, di, uo) is det.
 	% Given a character C, write C, escaped if necessary, to stdout.
@@ -528,9 +531,10 @@
 %-----------------------------------------------------------------------------%
 
 term_io__quote_char(C) -->
-	io__write_char(''''),
-	term_io__write_escaped_char(C),
-	io__write_char('''').
+	io__write_string(term_io__quoted_char(C)).
+
+term_io__quoted_char(C) =
+	string__format("'%s'", [s(term_io__escaped_char(C))]).
 
 term_io__quote_atom(S) -->
 	term_io__quote_atom(S, not_adjacent_to_graphic_token).
--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------



More information about the reviews mailing list