1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
2
3    Author:        Jan Wielemaker and Anjo Anjewierden
4    E-mail:        J.Wielemaker@vu.nl
5    WWW:           http://www.swi-prolog.org/packages/xpce/
6    Copyright (c)  2001-2014, University of Amsterdam
7                              VU University Amsterdam
8    All rights reserved.
9
10    Redistribution and use in source and binary forms, with or without
11    modification, are permitted provided that the following conditions
12    are met:
13
14    1. Redistributions of source code must retain the above copyright
15       notice, this list of conditions and the following disclaimer.
16
17    2. Redistributions in binary form must reproduce the above copyright
18       notice, this list of conditions and the following disclaimer in
19       the documentation and/or other materials provided with the
20       distribution.
21
22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
33    POSSIBILITY OF SUCH DAMAGE.
34*/
35
36:- module(prolog_term_view,
37          [ view_term/1,                % +Term
38            view_term/2                 % +Term, +Attributes
39          ]).
40:- use_module(library(pce)).
41:- require([ is_stream/1,
42	     current_blob/2,
43	     member/2,
44	     option/2,
45	     portray_clause/2,
46	     print_term/2,
47	     stream_property/2,
48	     merge_options/3,
49	     option/3,
50	     portray_clause/3,
51	     send_list/3,
52	     setup_call_cleanup/3
53	   ]).
54
55/** <module> Graphical viewer for Prolog terms
56
57This module implements an XPCE  widget   that  exploits  print_term/2 to
58display a Prolog term. The widget provides   buttons to control the most
59important options to control the output.
60*/
61
62%!  view_term(@Term) is det.
63%!  view_term(@Term, +Options) is det.
64%
65%   Display a Prolog term in  an   XPCE  window. Options defines the
66%   following options:
67%
68%       * view(?Object)
69%       XPCE object reference to create or re-use.
70%       * clear(+Boolean)
71%       Clear view before showing term (default: =true=)
72%       * open(+Boolean)
73%       Send an ->open message to the XPCE object (default: =true=)
74%       * expose(+Boolean)
75%       Send an ->expose message to the XPCE object (default: =false)
76%       * write_option(+Options)
77%       Options to pass to write_term/3.  Current defaults are:
78%           - quoted(true)
79%           - portray(true)
80%           - numbervars(true)
81%           - attributes(portray)
82%           - max_depth(100)
83
84view_term(Term) :-
85    view_term(Term, []).
86
87view_term(Term, _) :-                   % TBD: Turn into user hook!
88    object(Term),
89    !,
90    auto_call(manpce),
91    send(@manual, inspect, Term).
92view_term(Term, Attributes0) :-
93    defaults(Defs),
94    merge_options(Attributes0, Defs, Attributes),
95    tv(Term, Attributes).
96
97defaults([ view(@view_term),
98           clear(true),
99           open(true),
100           expose(false),
101           write_options([ quoted(true),
102                           portray(true),
103                           numbervars(true),
104                           attributes(portray),
105                           max_depth(100)
106                         ])
107         ]).
108
109tv(Term,Opts) :-
110    option(view(V),Opts),
111    (option(clear(true),Opts)         -> send(V, clear)               ; true),
112    (option(open(true),Opts)          -> send(V, open)                ; true),
113    (option(expose(true),Opts)        -> send(V, expose)              ; true),
114    (option(comment(Comment),Opts)    -> send(V, label, Comment)      ; true),
115    (option(source_object(Frag),Opts) -> send(V, source_object, Frag) ; true),
116    get(V, text_buffer, TB),
117    setup_call_cleanup(pce_open(TB, write, Fd),
118                       emit_term(Term, [output(Fd)|Opts]),
119                       close(Fd)),
120    send(V, caret, 0),
121    send(V, editable, @off),
122    (   option(write_options(WrtOpts),Opts)
123    ->  send(V, show_options, WrtOpts)
124    ;   true
125    ).
126
127
128%!  emit_term(+Term, +Options) is det.
129%
130%   Actually emit the term into @view_term.   One  of the Options is
131%   output(+Stream).
132
133emit_term(Term, Options) :-
134    is_stream(Term),
135    !,
136    option(output(Out), Options, current_output),
137    print_stream_properties(Term, Out).
138emit_term(Term, Options) :-
139    current_blob(Term, record),
140    !,
141    option(output(Out), Options, current_output),
142    print_record_properties(Term, Out).
143emit_term(Term, Options) :-
144    current_blob(Term, clause),
145    !,
146    option(output(Out), Options, current_output),
147    print_clause_properties(Term, Out).
148emit_term(Term, Options) :-
149    clause_term(Term),
150    !,
151    option(output(Out), Options, current_output),
152    portray_clause(Out, Term, Options).
153emit_term(Term, Options) :-
154    print_term(Term, Options).
155
156
157clause_term(Var) :-
158    var(Var), !, fail.
159clause_term(_:-_).
160clause_term(:-_).
161clause_term((_,_)).
162clause_term(_;_).
163clause_term(_->_).
164clause_term(_*->_).
165
166
167print_stream_properties(Stream, Out) :-
168    format(Out, 'Stream ~w~n', [Stream]),
169    (   stream_property(Stream, P),
170        (   atom(P)
171        ->  format(Out, '\t~q~n', [P])
172        ;   P =.. [Name,Value],
173            format(Out, '\t~w = ~p~n', [Name, Value])
174        ),
175        fail
176    ;   true
177    ).
178
179print_record_properties(Record, Out) :-
180    format(Out, 'Record reference ~w~n', [Record]),
181    (   recorded(Key, Value, Record)
182    ->  format(Out, '\tKey:   ~p~n', [Key]),
183        format(Out, '\tValue: ~p~n', [Value])
184    ;   format(Out, '\t<erased>~n', [])
185    ).
186
187print_clause_properties(Ref, Out) :-
188    format(Out, 'Clause reference ~w~n', [Ref]),
189    (   clause(Head, Body, Ref)
190    ->  nl(Out),
191        portray_clause(Out, (Head:-Body))
192    ;   format(Out, '\t<erased>~n', [])
193    ).
194
195
196
197                 /*******************************
198                 *      CLASS TERM-VIEWER       *
199                 *******************************/
200
201:- pce_global(@view_term, new(term_viewer)).
202
203:- pce_begin_class(term_viewer, frame,
204                   "Pretty-print a Prolog term").
205
206initialise(TV) :->
207    send_super(TV, initialise),
208    send(TV, append, new(TD, dialog)),
209    send(new(view), below, TD),
210    send(TD, border, size(0,2)),
211    send(TD, append, new(M, menu(options, toggle,
212                                 message(TV, update)))),
213    send(M, layout, horizontal),
214    send_list(M, append,
215              [ portray,
216                quoted,
217                max_depth
218              ]),
219    send(TD, append, int_item(max_depth, 100,
220                              message(TV, update), 1),
221         right).
222
223clear(TV) :->
224    get(TV, member, view, View),
225    send(View, clear).
226
227text_buffer(TV, TB:text_buffer) :<-
228    get(TV, member, view, View),
229    get(View, text_buffer, TB).
230
231caret(TV, Caret:int) :->
232    get(TV, member, view, View),
233    send(View, caret, Caret).
234
235editable(TV, E:bool) :->
236    get(TV, member, view, View),
237    send(View, editable, E).
238
239source_object(TV, Obj:object) :->
240    send(TV, delete_hypers, source),
241    new(_, hyper(TV, Obj, source, view)).
242
243update(TV) :->
244    get(TV, member, dialog, D),
245    get(D, member, options, Menu),
246    get(Menu, selection, Options),
247    make_options([ portray,
248                   quoted
249                 ], Options, OptionList0),
250    get(D, member, max_depth, DepthItem),
251    (   send(Options, member, max_depth),
252        send(DepthItem, active, @on),
253        get(DepthItem, selection, MaxDepth)
254    ->  OptionList = [max_depth(MaxDepth)|OptionList0]
255    ;   send(DepthItem, active, @off),
256        OptionList = OptionList0
257    ),
258    get(TV, hypered, source, Source),
259    get(Source, value, Term),
260    tv(Term,
261       [ view(TV),
262         clear(true),
263         write_options(OptionList)
264       ]).
265
266make_options([], _, [ numbervars(true), attributes(portray) ]).
267make_options([H0|T0], Selection, [H|T]) :-
268    (   send(Selection, member, H0)
269    ->  V = true
270    ;   V = false
271    ),
272    H =.. [H0,V],
273    make_options(T0, Selection, T).
274
275show_options(V, Options:prolog) :->
276    "Show current option values"::
277    get(V, member, dialog, D),
278    get(D, member, options, Menu),
279    send(Menu, selected, max_depth, @off),
280    get(D, member, max_depth, DepthItem),
281    send(DepthItem, active, @off),
282    (   member(Option, Options),
283        functor(Option, Name, 1),
284        get(Menu, member, Name, Item),
285        arg(1, Option, Value),
286        (   Name == max_depth
287        ->  send(Item, selected, @on),
288            send(DepthItem, active, @on),
289            send(DepthItem, selection, Value)
290        ;   send(Item, selected, Value)
291        ),
292        fail
293    ;   true
294    ).
295
296:- pce_end_class.
297