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(html_write,
36          [ page/3,                     % generate an HTML page
37            page/4,                     % page from head and body
38            html/3,
39
40                                        % Useful primitives for expanding
41            html_begin/3,               % +EnvName[(Attribute...)]
42            html_end/3,                 % +EnvName
43            html_quoted/3,              % +Text
44            html_quoted_attribute/3,    % +Attribute
45
46                                        % Emitting the HTML code
47            print_html/1,               % +List
48            print_html/2,               % +Stream, +List
49            html_print_length/2         % +List, -Length
50          ]).
51:- use_module(library(quintus)).        % for meta_predicate/1
52
53:- meta_predicate
54    html(:, -, +),
55    page(:, -, +),
56    page(:, :, -, +),
57    pagehead(:, -, +),
58    pagebody(:, -, +).
59
60/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
61library(html_write)
62
63The purpose of this library  is  to   simplify  writing  HTML  pages. Of
64course, it is possible to use format/[2,3]   to write to the HTML stream
65directly, but this is generally not very satisfactory:
66
67        * It is a lot of typing
68        * It does not guarantee proper HTML syntax.  You have to deal
69          with HTML quoting, proper nesting and reasonable layout.
70        * It is hard to use satisfactory abstraction
71
72This module tries to remedy these problems.   The idea is to translate a
73Prolog term into  an  HTML  document.  We   use  DCG  for  most  of  the
74generation.
75- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
76
77page(Content) -->
78    [ '<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 4.0//EN">\n',
79      '<html>',
80      nl(1)
81    ],
82    html(Content),
83    [ nl(1),
84      '</html>\n'
85    ].
86
87page(Head, Body) -->
88    [ '<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 4.0//EN">\n',
89      '<html>',
90      nl(1)
91    ],
92    pagehead(Head),
93    pagebody(Body),
94    [ nl(1),
95      '</html>\n'
96    ].
97
98pagehead(Head) -->
99    { strip_module(Head, M, _),
100      hook_module(M, head(_,_,_))
101    },
102    !,
103    M:head(Head).
104pagehead(Head) -->
105    html(head(Head)).
106
107
108pagebody(Body) -->
109    { strip_module(Body, M, _),
110      hook_module(M, body(_,_,_))
111    },
112    !,
113    M:body(Body).
114pagebody(Body) -->
115    html(body([bgcolor(white)], Body)).
116
117
118hook_module(M, P) :-
119    current_predicate(_, M:P),
120    !.
121hook_module(user, P) :-
122    current_predicate(_, user:P).
123
124
125
126html(Spec) -->
127    { strip_module(Spec, M, T)
128    },
129    html(T, M).
130
131html([], _) -->
132    !,
133    [].
134html([H|T], M) -->
135    !,
136    (   do_expand(H, M)
137    ->  []
138    ;   { print_message(error, html(expand_failed(H)))
139        }
140    ),
141    html(T, M).
142html(X, M) -->
143    do_expand(X, M).
144
145:- multifile
146    expand/3.
147
148do_expand(Token, _) -->                 % call user hooks
149    expand(Token),
150    !.
151do_expand(Fmt-Args, _) -->
152    !,
153    { sformat(String, Fmt, Args)
154    },
155    html_quoted(String).
156do_expand(\List, _) -->
157    { is_list(List)
158    },
159    !,
160    List.
161do_expand(\Term, Module, In, Rest) :-
162    !,
163    call(Module:Term, In, Rest).
164do_expand(Module:Term, _, In, Rest) :-
165    !,
166    call(Module:Term, In, Rest).
167do_expand(script(Content), _) -->      % general CDATA declared content elements?
168    !,
169    html_begin(script),
170    [ Content
171    ],
172    html_end(script).
173do_expand(&(Entity), _) -->
174    !,
175    { atomic_list_concat([&, Entity, ;], HTML)
176    },
177    [ HTML ].
178do_expand(Token, _) -->
179    { atomic(Token)
180    },
181    !,
182    html_quoted(Token).
183do_expand(element(Env, Attributes, Contents), M) -->
184    !,
185    html_begin(Env, Attributes),
186    html(Contents, M),
187    html_end(Env).
188do_expand(Term, M) -->
189    { Term =.. [Env, Contents]
190    },
191    !,
192    (   { layout(Env, _, empty)
193        }
194    ->  html_begin(Env, Contents)
195    ;   html_begin(Env),
196        html(Contents, M),
197        html_end(Env)
198    ).
199do_expand(Term, M) -->
200    { Term =.. [Env, Attributes, Contents]
201    },
202    !,
203    html_begin(Env, Attributes),
204    html(Contents, M),
205    html_end(Env).
206
207
208html_begin(Env) -->
209    { Env =.. [Name|Attributes]
210    },
211    html_begin(Name, Attributes).
212
213html_begin(Env, Attributes) -->
214    pre_open(Env),
215    [<],
216    [Env],
217    attributes(Attributes),
218    [>],
219    post_open(Env).
220
221html_end(Env)   -->                     % empty element or omited close
222    { layout(Env, _, -)
223    ; layout(Env, _, empty)
224    },
225    !,
226    [].
227html_end(Env)   -->
228    pre_close(Env),
229    ['</'],
230    [Env],
231    ['>'],
232    post_close(Env).
233
234attributes([]) -->
235    !,
236    [].
237attributes([H|T]) -->
238    !,
239    attribute(H),
240    attributes(T).
241attributes(One) -->
242    attribute(One).
243
244attribute(Name=Value) -->
245    !,
246    [' ', Name, '="' ],
247    html_quoted_attribute(Value),
248    ['"'].
249attribute(Term) -->
250    { Term =.. [Name, Value]
251    },
252    !,
253    attribute(Name=Value).
254attribute(Atom) -->                     % Value-abbreviated attribute
255    { atom(Atom)
256    },
257    [ ' ', Atom ].
258
259
260                 /*******************************
261                 *         QUOTING RULES        *
262                 *******************************/
263
264%       html_quoted(Text)
265%
266%       Quote the value for normal text.
267
268html_quoted(Text) -->
269    { sub_atom(Text, _, _, _, <)
270    ; sub_atom(Text, _, _, _, >)
271    ; sub_atom(Text, _, _, _, &)
272    },
273    !,
274    { atom_chars(Text, Chars),
275      quote_chars(Chars, QuotedChars),
276      atomic_list_concat(QuotedChars, Quoted)
277    },
278    [ Quoted ].
279html_quoted(Text) -->
280    [ Text ].
281
282quote_chars([], []).
283quote_chars([H0|T0], [H|T]) :-
284    quote_char(H0, H),
285    quote_chars(T0, T).
286
287quote_char(<, '&lt;') :- !.
288quote_char(>, '&gt;') :- !.
289quote_char(&, '&amp;') :- !.
290quote_char(X, X).
291
292%       html_quoted_attribute(+Text)
293%
294%       Quote the value according to the rules for tag-attributes
295
296html_quoted_attribute(Text) -->
297    { sub_atom(Text, _, _, _, <)
298    ; sub_atom(Text, _, _, _, >)
299%   ; sub_atom(Text, _, _, _, &)
300    ; sub_atom(Text, _, _, _, '"')
301%   ; sub_atom(Text, _, _, _, '''')
302    },
303    !,
304    { atom_chars(Text, Chars),
305      quote_att_chars(Chars, QuotedChars),
306      atomic_list_concat(QuotedChars, Quoted)
307    },
308    [ Quoted ].
309html_quoted_attribute(Text) -->
310    [ Text ].
311
312quote_att_chars([], []).
313quote_att_chars([H0|T0], [H|T]) :-
314    quote_att_char(H0, H),
315    quote_att_chars(T0, T).
316
317quote_att_char(<, '&lt;') :- !.
318quote_att_char(>, '&gt;') :- !.
319%quote_att_char(&, '&amp;') :- !.
320quote_att_char('"', '&quot;') :- !.
321%quote_att_char('''', '&apos;') :- !.
322quote_att_char(X, X).
323
324
325                 /*******************************
326                 *             LAYOUT           *
327                 *******************************/
328
329pre_open(Env) -->
330    { layout(Env, N-_, _)
331    },
332    !,
333    [ nl(N) ].
334pre_open(_) --> [].
335
336post_open(Env) -->
337    { layout(Env, _-N, _)
338    },
339    !,
340    [ nl(N) ].
341post_open(_) -->
342    [].
343
344pre_close(Env) -->
345    { layout(Env, _, N-_)
346    },
347    !,
348    [ nl(N) ].
349pre_close(_) -->
350    [].
351
352post_close(Env) -->
353    { layout(Env, _, _-N)
354    },
355    !,
356    [ nl(N) ].
357post_close(_) -->
358    [].
359
360%       layout(Tag, PreOpen-PostOpen, PreClose-PostClose)
361%
362%       Define required newlines before and after tags.  This table is
363%       rather incomplete.
364
365:- multifile
366    layout/3.
367
368layout(table,      2-1, 1-2).
369layout(blockquote, 2-1, 1-2).
370layout(center,     2-1, 1-2).
371layout(dl,         2-1, 1-2).
372layout(ul,         2-1, 1-2).
373layout(form,       2-1, 1-2).
374layout(frameset,   2-1, 1-2).
375
376layout(head,       1-1, 1-1).
377layout(body,       1-1, 1-1).
378layout(script,     1-1, 1-1).
379layout(select,     1-1, 1-1).
380layout(map,        1-1, 1-1).
381layout(html,       1-1, 1-1).
382
383layout(tr,         1-0, 0-1).
384layout(option,     1-0, 0-1).
385layout(li,         1-0, 0-1).
386layout(dt,         1-0, -).
387layout(dd,         0-0, -).
388layout(title,      1-0, 0-1).
389
390layout(h1,         2-0, 0-2).
391layout(h2,         2-0, 0-2).
392layout(h3,         2-0, 0-2).
393layout(h4,         2-0, 0-2).
394
395layout(hr,         1-1, empty).         % empty elements
396layout(br,         0-1, empty).
397layout(img,        0-0, empty).
398layout(meta,       1-1, empty).
399layout(base,       1-1, empty).
400layout(link,       1-1, empty).
401layout(input,      0-0, empty).
402layout(frame,      1-1, empty).
403layout(col,        0-0, empty).
404layout(area,       1-0, empty).
405layout(input,      1-0, empty).
406layout(option,     1-0, empty).
407
408layout(p,          2-1, -).             % omited close
409layout(td,         0-0, 0-0).
410
411
412                 /*******************************
413                 *           PRINTING           *
414                 *******************************/
415
416%       print_html(+Stream, +List)
417%
418%       Print list of atoms and layout instructions.  Currently used layout
419%       instructions:
420%
421%               nl(N)   Use at minimum N newlines here.
422
423print_html(List) :-
424    current_output(Out),
425    write_html(List, Out).
426print_html(Out, List) :-
427    write_html(List, Out).
428
429write_html([], _).
430write_html([nl(N)|T], Out) :-
431    !,
432    join_nl(T, N, Lines, T2),
433    write_nl(Lines, Out),
434    write_html(T2, Out).
435write_html([H|T], Out) :-
436    write(Out, H),
437    write_html(T, Out).
438
439join_nl([nl(N0)|T0], N1, N, T) :-
440    !,
441    N2 is max(N0, N1),
442    join_nl(T0, N2, N, T).
443join_nl(L, N, N, L).
444
445write_nl(0, _) :- !.
446write_nl(N, Out) :-
447    nl(Out),
448    N1 is N - 1,
449    write_nl(N1, Out).
450
451%       html_print_length(+List, -Len)
452%
453%       Determine the content length of the list.
454
455html_print_length(List, Len) :-
456    html_print_length(List, 0, Len).
457
458html_print_length([], L, L).
459html_print_length([nl(N)|T], L0, L) :-
460    !,
461    join_nl(T, N, Lines, T1),
462    L1 is L0 + Lines,               % assume only \n!
463    html_print_length(T1, L1, L).
464html_print_length([H|T], L0, L) :-
465    atom_length(H, Hlen),
466    L1 is L0+Hlen,
467    html_print_length(T, L1, L).
468
469
470                 /*******************************
471                 *            MESSAGES          *
472                 *******************************/
473
474:- multifile
475    prolog:message/3.
476
477prolog:message(html(expand_failed(What))) -->
478    [ 'Failed to translate to HTML: ~p'-[What] ].
479