1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
2
3    Author:        Jan Wielemaker and Anjo Anjewierden
4    E-mail:        jan@swi.psy.uva.nl
5    WWW:           http://www.swi.psy.uva.nl/projects/xpce/
6    Copyright (c)  2000-2011, University of Amsterdam
7    All rights reserved.
8
9    Redistribution and use in source and binary forms, with or without
10    modification, are permitted provided that the following conditions
11    are met:
12
13    1. Redistributions of source code must retain the above copyright
14       notice, this list of conditions and the following disclaimer.
15
16    2. Redistributions in binary form must reproduce the above copyright
17       notice, this list of conditions and the following disclaimer in
18       the documentation and/or other materials provided with the
19       distribution.
20
21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32    POSSIBILITY OF SUCH DAMAGE.
33*/
34
35:- module(pce_html_refman,
36          [ html_description/2,         % +Object, -HTMLString
37            atom_to_method/2,           % +Atom, -Behaviour
38            collect_behaviour/2,        % +Class, -Behaviour
39            group_objects/2,            % +Behaviour, -Groups
40            cluster_behaviour/2,        % +Chain, -NestedChain
41            group_summary/2             % +Group, -Summary
42          ]).
43:- use_module(library(pce)).
44:- use_module(library(pce_manual)).
45
46:- dynamic
47    drain/1,                        % the output object (editor)
48    regex/2,                        % cache for created regular expr.
49    fetched_description/2,          % cache for computed descriptions
50    no_inherit_description/3.       % Forbit inheritance of description
51
52%       atom_to_method(+Spec, -Method)
53%
54%       Find XPCE object holding documentation from a textual specification.
55
56atom_to_method(String, Object) :-
57    (   new(Re, regex('([A-Z]?[a-z_]*)\\s*(<?->?)([a-z_]+)(:.*)?$')),
58        send(Re, match, String)
59    ->  get(Re, register_value, String, 1, name, Class0),
60        get(Re, register_value, String, 2, name, What0),
61        get(Re, register_value, String, 3, name, Selector),
62        get(Class0, downcase, Class),
63        (   What0 == '<->'
64        ->  member(What, ['->', '<-'])
65        ;   What = What0
66        ),
67        Term =.. [What, Class, Selector]
68    ;   new(Re, regex('@(.+)$')),
69        send(Re, match, String)
70    ->  get(Re, register_value, String, 1, name, Reference),
71        Term = @Reference
72    ;   Term = String
73    ),
74    pce_manual:method(Term, Object).
75
76
77
78:- pce_global(@documented, new(chain)). % Chain with documented objects
79
80excluded(Obj, InheritedFrom, _Description) :-
81    no_inherit_description(Type, FromClass, Selector),
82    send(Obj, instance_of, Type),
83    get(Obj, name, Selector),
84    send(InheritedFrom?context, is_a, FromClass).
85
86fetch_description(@Obj, Description) :-
87    fetched_description(Obj, Description),
88    !.
89fetch_description(Obj, Description) :-
90    get(Obj, '_class_name', var),
91    !,
92    get(@manual, self, _),          % force creation
93    Obj = @Ref,
94    new(Global, man_global(Ref)),
95    fetch_description(Global, Description),
96    assert(fetched_description(Ref, Description)).
97fetch_description(Obj, Description) :-
98    get(@manual, self, _),          % force creation
99    (   get(Obj, attribute, man_description, S0)
100    ;   get(Obj, man_attribute, description, S0)
101    ;   get(Obj, man_inherited_attribute, description, tuple(From, S0)),
102        \+ excluded(Obj, From, S0)
103    ;   send(Obj, has_get_method, summary),
104        get(Obj, summary, S0)
105    ;   new(S0, string),
106        send(S0, lock_object, @on)
107    ),
108    S0 \== @nil,
109    !,
110    Obj = @Ref,
111    assert(fetched_description(Ref, S0)),
112    Description = S0.
113
114
115:- pce_extend_class(object).
116
117fetch_description(Obj, Description) :<-
118    "Cached description slot using manual rules"::
119    fetch_description(Obj, Description).
120
121:- pce_end_class.
122
123html_description(Obj, S1) :-
124    fetch_description(Obj, S0),
125    get(S0, copy, S1),
126    desc_to_html(S1, Obj).
127
128%       to_regex(+Pattern, -Regex)
129%
130%       Convert pattern to regex, maintaining a store of regex objects
131%       to avoid unnecessary recompilation.  We cannot blindly reuse
132%       the regex as they are used recursively.
133
134to_regex(Pattern, Regex) :-
135    retract(regex(Pattern, Regex)),
136    !.
137to_regex(Pattern, Regex) :-
138    new(Regex, regex(Pattern)),
139    send(Regex, lock_object, @on),
140    send(Regex, compile, @on).
141
142done_regex(Pattern, Regex) :-
143    assert(regex(Pattern, Regex)).
144
145substitute(_, []) :- !.
146substitute(S, [Search, Replace | Rest]) :-
147    to_regex(Search, Re),
148    (   Replace = call(Head)
149    ->  Head =.. [Pred|Args],
150        append(Args, [@arg1, @arg2], AllArgs),
151        Msg =.. [message, @prolog, Pred | AllArgs],
152        send(Re, for_all, S, Msg)
153    ;   send(Re, for_all, S,
154             message(@arg1, replace, @arg2, Replace))
155    ),
156    done_regex(Search, Re),
157    substitute(S, Rest).
158
159
160desc_to_html(S, Obj) :-
161    send(S, ensure_nl),
162    html_escape(S),
163    substitute(S, ['\n\\s+\n', '\n\n']), % cannonise
164    html_lists(S),
165    substitute(S,
166               [ %   HEADING
167                 '\n\n\\s*([A-Z ?!._-]+)\\s*\n\n',
168                    call(header),   % uses \1
169                 %   ** SubHeader
170                 '\n\n\\*\\*+\\s+(.*)\n\n',
171                    '\n\n<h4>\\1</h4>\n\n',
172                 %   *bold*
173                 '\\*([^ ]+)\\*',
174                    '<b>\\1</b>'
175               ]),
176    substitute(S, ['\n\n+', '\n\n<p>\n']), % paragraphs
177    hyperlinks(S, Obj),
178    send(S, strip).
179
180
181html_lists(S) :-
182    substitute(S,
183               [ %   1)
184                 %   2)
185                 '\n\n+(\t\\d+\\).*(\n\t.*|\n *)*)',
186                    call(enumerate),
187                 %   aap    noot
188                 %   zus    jet
189                 '\n\n((\n*\t[^\t\n]+\t.*\n)+)',
190                    call(table),
191                 %   * header
192                 %   text
193                 '\n\n+(\t\\*.*(\n\t.*|\n *)*)',
194                    call(itemize),
195                 %   # text
196                 %   more text
197                 '\n\n+(\t#.*(\n\t.*|\n *)*)',
198                    call(description),
199                 %   Indented by tabs
200%                    '\n\n+\\(\\(\n*\t.*\\)+\\)',       % fails on regex 0.12
201                 '\n+((\n+\t.*)+)',
202                    call(example)
203               ]).
204
205
206example(Re, String) :-
207    get(Re, register_value, String, 1, S2),
208    substitute(S2, ['^\t(.*)', '\\1']),
209    send(S2, untabify, 4),
210    send(S2, prepend, string('\n<pre>')),
211    send(S2, append, string('\n</pre>\n')),
212    send(Re, register_value, String, S2).
213
214
215list(description, Re, String) :-
216    get(Re, register_value, String, 1, L1),
217    get(Re, register_value, String, 2, RestLines),
218    substitute(RestLines, ['\n\t', '\n']),
219    send(RestLines, strip, trailing),
220    send(RestLines, ensure_nl),
221    html_lists(RestLines),  % sub-lists
222    send(RestLines, strip),
223    send(RestLines, ensure_nl),
224    send(RestLines, prepend, string('<dt>&nbsp;<br>%s<dd>\n', L1)),
225    send(Re, register_value, String, RestLines).
226list(itemize, Re, String) :-
227    get(Re, register_value, String, 1, L1),
228    get(Re, register_value, String, 2, RestLines),
229    new(S0, string('\n%s%s', L1, RestLines)),
230    substitute(S0, ['\n\t', '\n']),
231    send(S0, strip, trailing),
232    send(S0, ensure_nl),
233    html_lists(S0), % sub-lists
234    send(S0, strip),
235    send(S0, ensure_nl),
236    send(S0, prepend, string('<li>\n')),
237    send(Re, register_value, String, S0).
238
239
240itemize(Re, String) :-
241    get(Re, register_value, String, 1, S2),
242    substitute(S2,
243               [ '\n*\t\\*\\s*(.*)((\n\t[^*].*|\n *)*)',
244                    call(list(itemize))
245               ]),
246    send(S2, prepend, string('\n<p><ul>\n')),
247    send(S2, ensure_nl),
248    send(S2, append, string('</ul><p>\n')),
249    send(Re, register_value, String, S2).
250
251
252description(Re, String) :-
253    get(Re, register_value, String, 1, S2),
254    substitute(S2,
255               [ '\n*\t#\\s*(.*)((\n\t[^#].*|\n *)*)',
256                    call(list(description))
257               ]),
258    send(S2, ensure_nl),
259    send(S2, prepend, string('\n<dl>\n')),
260    send(S2, append, string('</dl>\n')),
261    send(Re, register_value, String, S2).
262
263
264enumerate(Re, String) :-
265    get(Re, register_value, String, 1, S2),
266    substitute(S2,
267               [ '\n*\t\\d+\\)\\s*(.*)((\n\t[^0-9].*|\n *)*)',
268                    call(list(itemize))
269               ]),
270    send(S2, ensure_nl),
271    send(S2, prepend, string('\n<ol>\n')),
272    send(S2, append, string('</ol>\n')),
273    send(Re, register_value, String, S2).
274
275
276table(Re, String) :-
277    get(Re, register_value, String, 1, S2),
278    substitute(S2,
279               [ '\n*\t([^\t]+)\t+(.*)\n',
280                   '<tr><td>\\1<td>\\2</tr>\n'
281               ]),
282    send(S2, prepend, string('\n<p><table align=center border=1 width=50%>\n')),
283    send(S2, append, string('</table>\n')),
284    send(Re, register_value, String, S2).
285
286
287header(Re, String) :-
288    get(Re, register_value, String, 1, ALLCAPITALS),
289    get(ALLCAPITALS, capitalise, Capitals),
290    send(Re, register_value, String,
291         string('<h4>%s</h4>', Capitals), 1).
292
293
294                 /*******************************
295                 *         HYPERLINKS           *
296                 *******************************/
297
298%       hyperlinks(+String, +Object)
299%
300%       Use the typographical conventions in the XPCE manual description
301%       to automatically create hyperlinks.
302
303hyperlinks(S, Obj) :-
304    substitute(S,
305               [ '`([^`\']+)\'',
306                    call(make_link),
307                 '-&gt;([a-z_]+)',
308                    call(make_sendmethod_link(Obj)),
309                 '&lt;-([a-z_]+)',
310                    call(make_getmethod_link(Obj)),
311                 '(@[a-z_]+)',
312                    call(make_link),
313                 '\\y[Cc]lass\\s+([a-z_]+)',
314                    call(make_link),
315                 '([a-z_]+)\\s+object\\y',
316                    call(make_link)
317               ]).
318
319make_link(Re, String) :-
320    get(Re, register_value, String, 1, Spec),
321    html_unescape(Spec),
322    get(Spec, value, Atom),
323    atom_to_method(Atom, _),
324    !,
325    www_form_encode(Atom, Encoded),
326    send(Re, register_value, String,
327        string('<a href="/man?for=%s">%s</a>', Encoded, Spec), 1).
328make_link(_, _).
329
330make_sendmethod_link(Obj, Re, String) :-
331    get(Re, register_value, String, 1, name, Method),
332    context_class(Obj, Class),
333    get(string('%s->%s', Class, Method), value, Atom),
334    atom_to_method(Atom, _),
335    !,
336    www_form_encode(Atom, Encoded),
337    get(Re, register_value, String, 0, In),
338    send(Re, register_value, String,
339         string('<a href="/man?for=%s">%s</a>', Encoded, In)).
340make_sendmethod_link(_,_,_).
341
342make_getmethod_link(Obj, Re, String) :-
343    get(Re, register_value, String, 1, name, Method),
344    context_class(Obj, Class),
345    get(string('%s<-%s', Class, Method), value, Atom),
346    atom_to_method(Atom, _),
347    !,
348    www_form_encode(Atom, Encoded),
349    get(Re, register_value, String, 0, In),
350    send(Re, register_value, String,
351         string('<a href="/man?for=%s">%s</a>', Encoded, In)).
352make_getmethod_link(_,_,_).
353
354
355context_class(Class, Name) :-
356    send(Class, instance_of, class),
357    !,
358    get(Class, name, Name).
359context_class(Obj, Name) :-
360    send(Obj, has_get_method, context),
361    get(Obj, context, Class),
362    send(Class, instance_of, class),
363    !,
364    get(Class, name, Name).
365
366
367                 /*******************************
368                 *           ESCAPING           *
369                 *******************************/
370
371html_escape(S) :-
372    substitute(S, [ '&',   '&amp;',
373                    '<',   '&lt;',
374                    '>',   '&gt;'
375                  ]).
376
377html_unescape(S) :-
378    substitute(S, [ '&amp;', '&',
379                    '&lt;',  '<',
380                    '&gt;',  '>'
381                  ]).
382
383
384                 /*******************************
385                 *           BEHAVIOUR          *
386                 *******************************/
387
388collect_behaviour(Class, Behaviour) :-
389    new(Behaviour, chain),
390
391    new(Merge, message(Behaviour, append, @arg1)),
392
393    send(Class?get_methods, for_all, Merge),
394    send(Class?send_methods, for_all, Merge),
395    send(Class?instance_variables, for_all,
396         if(@arg1?context == Class,
397            message(Behaviour, append, @arg1))).
398
399
400group_objects(Chain, Groups) :-
401    new(Groups, sheet),
402    Group = when(@arg1?group, @arg1?group, miscellaneous),
403    send(Chain, for_all,
404         if(message(Groups, is_attribute, Group),
405            message(?(Groups, value, Group), append, @arg1),
406            message(Groups, value, Group,
407                    ?(@pce, instance, chain, @arg1)))),
408
409    SortByName = ?(@arg1?name, compare, @arg2?name),
410
411    order_groups(Groups),
412
413    send(Groups?members, for_all,
414         message(@arg1?value, sort,
415                 quote_function(SortByName))).
416
417order_groups(Sheet) :-
418    get(@manual, module, groups, @on, GroupModule),
419    get(GroupModule, id_table, Table),
420    get(Sheet, members, Chain),
421    new(Unordered, chain),
422    send(Chain, for_all,
423         if(not(?(Table, member, @arg1?name)),
424            and(message(Unordered, append, @arg1),
425                message(Chain, delete, @arg1)))),
426    send(Chain, sort,
427         ?(?(Table, member, @arg1?name)?index, compare,
428           ?(Table, member, @arg2?name)?index)),
429    send(Chain, merge, Unordered).
430
431
432cluster_behaviour(Chain, Combined) :-
433    new(Combined, chain),
434    send(Chain, for_all,
435         and(assign(new(B, var), @arg1),
436             or(and(assign(new(Ch, var),
437                           ?(Combined, find,
438                             message(@arg1?head?fetch_description, equal,
439                                     B?fetch_description))),
440                    message(Ch, append, B)),
441                message(Combined, append,
442                        ?(@pce, instance, chain, B))))),
443    send(Combined, for_all, message(@prolog, sort_cluster, @arg1)).
444
445
446sort_cluster(Chain) :-
447    send(Chain, sort, ?(@prolog, compare_cluster_elements,
448                        @arg1?class_name, @arg2?class_name)).
449
450compare_cluster_elements(X,                 X, equal).
451compare_cluster_elements(delegate_variable, _, smaller).
452compare_cluster_elements(variable,          _, smaller).
453compare_cluster_elements(get_method,        _, smaller).
454compare_cluster_elements(send_method,       _, larger).
455compare_cluster_elements(X,                 _, _) :-
456    format('[WARNING: compare_cluster_elements/3: Illegal first element ~w]~n', X),
457    fail.
458
459group_summary(Group, Summary) :-
460    get(@manual, module, groups, @on, Module),
461    get(Module?id_table, member, Group, GroupCard),
462    get(GroupCard, summary, Summary),
463    Summary \== @nil.
464
465
466                 /*******************************
467                 *          HELP X-REF          *
468                 *******************************/
469
470:- dynamic
471    prolog:called_by/2.
472:- multifile
473    prolog:called_by/2.
474
475prolog:called_by(substitute(_, []), []) :- !.
476prolog:called_by(substitute(S, [_,call(Head)|Rest]), [H|T]) :-
477    catch(Head =.. L, _, fail),
478    !,
479    append(L, [_,_], L2),
480    H =.. L2,
481    prolog:called_by(substitute(S, Rest), T).
482prolog:called_by(substitute(S, [_,_|Rest]), Called) :-
483    prolog:called_by(substitute(S, Rest), Called).
484
485
486
487
488