[m-rev.] Make pprint handle operators
Ralph Becket
rafe at cs.mu.OZ.AU
Tue Jan 21 17:14:54 AEDT 2003
Estimated hours taken: 3
Branches: main
library/pprint.m:
Change pprint so that standard pre/post/infix operators are printed
that way.
tests/hard_coded/pprint_test2.m:
tests/hard_coded/pprint_test2.exp:
tests/hard_coded/pprint_test2.Makefile:
Test case added.
Index: library/pprint.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/pprint.m,v
retrieving revision 1.12
diff -u -r1.12 pprint.m
--- library/pprint.m 29 Oct 2002 16:51:27 -0000 1.12
+++ library/pprint.m 21 Jan 2003 06:11:31 -0000
@@ -370,7 +370,7 @@
:- implementation.
-:- import_module array, map, sparse_bitset, enum, term, exception.
+:- import_module array, map, sparse_bitset, enum, term, exception, ops.
:- type doc
---> 'NIL'
@@ -393,6 +393,10 @@
:- type map_pair(K, V)
---> map_pair(K, V).
+ % Used for depth-limit arguments.
+ %
+:- type depth == int.
+
%-----------------------------------------------------------------------------%
doc(X) = doc(int__max_int, X).
@@ -647,10 +651,18 @@
%-----------------------------------------------------------------------------%
+ % Infix "," has precedence 1000 in standard Mercury.
+ %
+to_doc(Depth, X) = to_doc(Depth, 1000, X).
+
+%-----------------------------------------------------------------------------%
+
% This may throw an exception or cause a runtime abort if the term
% in question has user-defined equality.
%
-to_doc(Depth, X) =
+:- func to_doc(int, priority, T) = doc.
+
+to_doc(Depth, Priority, X) =
( if dynamic_cast_to_var(X, Var)
then var_to_doc(Depth, Var)
@@ -675,34 +687,144 @@
else if dynamic_cast_to_map_pair(X, MapPair)
then map_pair_to_doc(Depth, MapPair)
- else generic_term_to_doc(Depth, X)
+ else generic_term_to_doc(Depth, Priority, X)
).
%-----------------------------------------------------------------------------%
-:- func generic_term_to_doc(int, T) = doc.
+:- func generic_term_to_doc(depth, priority, T) = doc.
+
+generic_term_to_doc(Depth, Priority, X) = Doc :-
+
+ ( if
+
+ Depth =< 0
-generic_term_to_doc(Depth, X) = Doc :-
- ( if Depth =< 0
then
+
functor(X, Name, Arity),
- Doc =
- ( if Arity = 0
- then text(Name)
- else Name ++ "/" ++ Arity
- )
+ Doc = ( if Arity = 0 then text(Name) else Name ++ "/" ++ Arity )
+
else
- deconstruct(X, Name, Arity, UnivArgs),
+
+ deconstruct(X, Name, _Arity, UnivArgs),
+ Table = init_mercury_op_table,
Doc =
- ( if Arity = 0
- then text(Name)
- else group(
- Name ++ parentheses(
- nest(2, packed_cs_univ_args(Depth - 1, UnivArgs))
+ ( if
+
+ UnivArgs = [UnivArg],
+ lookup_prefix_op(Table, Name, OpPri, Assoc)
+
+ then
+
+ maybe_parens(Priority, OpPri,
+ Name ++
+ space ++
+ univ_to_doc(Depth - 1, OpPri `adjusted_by` Assoc,
+ UnivArg)
+ )
+
+ else if
+
+ UnivArgs = [UnivArg],
+ lookup_postfix_op(Table, Name, OpPri, Assoc)
+
+ then
+
+ maybe_parens(Priority, OpPri,
+ univ_to_doc(Depth - 1, OpPri `adjusted_by` Assoc,
+ UnivArg) ++
+ space ++
+ Name
+ )
+
+ else if
+
+ UnivArgs = [UnivArgL, UnivArgR],
+ lookup_infix_op(Table, Name, OpPri, AssocL, AssocR)
+
+ then
+
+ maybe_parens(Priority, OpPri,
+ univ_to_doc(Depth - 1, OpPri `adjusted_by` AssocL,
+ UnivArgL) ++
+ space ++
+ Name ++
+ space ++
+ group(line ++
+ nest(2,
+ univ_to_doc(Depth - 2, OpPri `adjusted_by` AssocR,
+ UnivArgR)
+ )
+ )
+ )
+
+ else if
+
+ UnivArgs = [UnivArgR1, UnivArgR2],
+ lookup_binary_prefix_op(Table, Name, OpPri, AssocR1, AssocR2)
+
+ then
+
+ maybe_parens(Priority, OpPri,
+ Name ++
+ space ++
+ univ_to_doc(Depth - 2, OpPri `adjusted_by` AssocR1,
+ UnivArgR1) ++
+ space ++
+ group(line ++
+ nest(2,
+ univ_to_doc(Depth - 2, OpPri `adjusted_by` AssocR2,
+ UnivArgR2)
)
)
+ )
+
+ else if
+
+ UnivArgs = []
+
+ then
+
+ text(Name)
+
+ else
+
+ group(
+ Name ++ parentheses(
+ nest(2, packed_cs_univ_args(Depth - 1, UnivArgs))
+ )
+ )
)
).
+
+%-----------------------------------------------------------------------------%
+
+ % We need to put parentheses around a subterm if its top-level
+ % functor has a higher priority than its parent functor.
+ %
+:- func maybe_parens(priority, priority, doc) = doc.
+
+maybe_parens(ParentPriority, OpPriority, Doc) =
+ ( if ParentPriority < OpPriority then parentheses(Doc) else Doc ).
+
+%-----------------------------------------------------------------------------%
+
+ % An x priority adjustment lowers the effective priority by one.
+ % A y priority adjustment does not affect the effective priority.
+ %
+:- func priority `adjusted_by` assoc = priority.
+
+Priority `adjusted_by` x = Priority - 1.
+Priority `adjusted_by` y = Priority.
+
+%-----------------------------------------------------------------------------%
+
+ % Convert a univ encapsulated value into a doc.
+ %
+:- func univ_to_doc(int, priority, univ) = doc.
+
+univ_to_doc(Depth, Priority, Univ) = to_doc(Depth, Priority, univ_value(Univ)).
%-----------------------------------------------------------------------------%
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.182
diff -u -r1.182 Mmakefile
--- tests/hard_coded/Mmakefile 17 Jan 2003 05:57:04 -0000 1.182
+++ tests/hard_coded/Mmakefile 21 Jan 2003 06:05:15 -0000
@@ -105,6 +105,7 @@
nullary_ho_func \
null_char \
pprint_test \
+ pprint_test2 \
pragma_c_code \
pragma_export \
pragma_import \
Index: tests/hard_coded/pprint_test2.exp
===================================================================
RCS file: tests/hard_coded/pprint_test2.exp
diff -N tests/hard_coded/pprint_test2.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/pprint_test2.exp 21 Jan 2003 06:05:27 -0000
@@ -0,0 +1,44 @@
+a
+f(a)
+- a
+f(- a)
+~ a
+f(~ a)
+(:- a)
+f((:- a))
+(:- - a)
+f((:- - a))
+(:- ~ a)
+f((:- ~ a))
+(:- a ++ a)
+f((:- a ++ a))
+- (- a)
+f(- (- a))
+~ ~ a
+f(~ ~ a)
+~ - a
+f(~ - a)
+- (~ a)
+f(- (~ a))
+a ++ a
+f(a ++ a)
+a ++ a ++ a
+f(a ++ a ++ a)
+(a ++ a) ++ a
+f((a ++ a) ++ a)
+a ++ a -- a
+f(a ++ a -- a)
+a -- (a ++ a)
+f(a -- (a ++ a))
+a -- a -- a
+f(a -- a -- a)
+a -- (a -- a)
+f(a -- (a -- a))
+(a -> a)
+f((a -> a))
+some a a
+f(some a a)
+some a some a a
+f(some a some a a)
+some (some a a) a
+f(some (some a a) a)
Index: tests/hard_coded/pprint_test2.m
===================================================================
RCS file: tests/hard_coded/pprint_test2.m
diff -N tests/hard_coded/pprint_test2.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/pprint_test2.m 21 Jan 2003 06:04:31 -0000
@@ -0,0 +1,102 @@
+%-----------------------------------------------------------------------------%
+% pprint_test2.m
+% Ralph Becket <rafe at cs.mu.oz.au>
+% Tue Jan 21 16:36:49 EST 2003
+% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
+%
+% Test operator pretty printing.
+%
+%-----------------------------------------------------------------------------%
+
+:- module foo.
+
+:- interface.
+
+:- import_module io.
+
+
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module pprint.
+
+:- type t
+ ---> a
+ ; f(t)
+ ; - t % fx
+ ; ~ t % fy
+ ; ( :- t ) % fx, high priority
+ ; t ++ t % xfy
+ ; t -- t % yfx
+ ; t == t % xfx
+ ; ( t -> t ) % xfy, high priority
+ ; { some t t }. % fxx
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+
+ ppout(a, !IO),
+
+ ppout(- a, !IO),
+
+ ppout(~ a, !IO),
+
+ ppout((:- a), !IO),
+
+ ppout((:- - a), !IO),
+
+ ppout((:- ~ a), !IO),
+
+ ppout((:- a ++ a), !IO),
+
+ ppout(- (- a), !IO),
+
+ ppout(~ ~ a, !IO),
+
+ ppout(~ - a, !IO),
+
+ ppout(- (~ a), !IO),
+
+ ppout(a ++ a, !IO),
+
+ ppout(a ++ a ++ a, !IO),
+
+ ppout((a ++ a) ++ a, !IO),
+
+ ppout(a ++ a -- a, !IO),
+
+ ppout(a -- (a ++ a), !IO),
+
+ ppout(a -- a -- a, !IO),
+
+ ppout(a -- (a -- a), !IO),
+
+ ppout((a -> a), !IO),
+
+ ppout((some a a), !IO),
+
+ ppout((some a some a a), !IO),
+
+ ppout((some (some a a) a), !IO),
+
+ true.
+
+%-----------------------------------------------------------------------------%
+
+:- pred ppout(t, io, io).
+:- mode ppout(in, di, uo) is det.
+
+ppout(T, !IO) :-
+ pprint.write(80, to_doc(T), !IO),
+ io.nl(!IO),
+ pprint.write(80, to_doc(f(T)), !IO),
+ io.nl(!IO).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list