35
36:- module(html_write,
37 [ reply_html_page/2, 38 reply_html_page/3, 39
40 41 page//1, 42 page//2, 43 page//3, 44 html//1, 45
46 47 html_set_options/1, 48 html_current_option/1, 49
50 51 html_post//2, 52 html_receive//1, 53 html_receive//2, 54 xhtml_ns//2, 55 html_root_attribute//2, 56
57 html/4, 58
59 60 html_begin//1, 61 html_end//1, 62 html_quoted//1, 63 html_quoted_attribute//1, 64
65 66 print_html/1, 67 print_html/2, 68 html_print_length/2, 69
70 71 (html_meta)/1, 72 op(1150, fx, html_meta)
73 ]). 74:- use_module(html_quasiquotations, [html/4]). 75:- autoload(library(apply),[maplist/3,maplist/4]). 76:- autoload(library(debug),[debug/3]). 77:- autoload(library(error),
78 [must_be/2,domain_error/2,instantiation_error/1]). 79:- autoload(library(lists),
80 [permutation/2,selectchk/3,append/3,select/4,list_to_set/2]). 81:- autoload(library(option),[option/2]). 82:- autoload(library(pairs),[group_pairs_by_key/2]). 83:- autoload(library(sgml),[xml_quote_cdata/3,xml_quote_attribute/3]). 84:- autoload(library(uri),[uri_encoded/3]). 85:- autoload(library(url),[www_form_encode/2]). 86:- autoload(library(http/http_dispatch), [http_location_by_id/2]). 87
89:- set_prolog_flag(generate_debug_info, false). 90
91:- meta_predicate
92 reply_html_page(+, :, :),
93 reply_html_page(:, :),
94 html(:, -, +),
95 page(:, -, +),
96 page(:, :, -, +),
97 pagehead(+, :, -, +),
98 pagebody(+, :, -, +),
99 html_receive(+, 3, -, +),
100 html_post(+, :, -, +). 101
102:- multifile
103 expand//1, 104 expand_attribute_value//1, 105 html_header_hook/1. 106
107
140
141
142 145
169
170html_set_options(Options) :-
171 must_be(list, Options),
172 set_options(Options).
173
174set_options([]).
175set_options([H|T]) :-
176 html_set_option(H),
177 set_options(T).
178
179html_set_option(dialect(Dialect0)) :-
180 !,
181 must_be(oneof([html,html4,xhtml,html5]), Dialect0),
182 ( html_version_alias(Dialect0, Dialect)
183 -> true
184 ; Dialect = Dialect0
185 ),
186 set_prolog_flag(html_dialect, Dialect).
187html_set_option(doctype(Atom)) :-
188 !,
189 must_be(atom, Atom),
190 current_prolog_flag(html_dialect, Dialect),
191 dialect_doctype_flag(Dialect, Flag),
192 set_prolog_flag(Flag, Atom).
193html_set_option(content_type(Atom)) :-
194 !,
195 must_be(atom, Atom),
196 current_prolog_flag(html_dialect, Dialect),
197 dialect_content_type_flag(Dialect, Flag),
198 set_prolog_flag(Flag, Atom).
199html_set_option(O) :-
200 domain_error(html_option, O).
201
202html_version_alias(html, html4).
203
207
208html_current_option(dialect(Dialect)) :-
209 current_prolog_flag(html_dialect, Dialect).
210html_current_option(doctype(DocType)) :-
211 current_prolog_flag(html_dialect, Dialect),
212 dialect_doctype_flag(Dialect, Flag),
213 current_prolog_flag(Flag, DocType).
214html_current_option(content_type(ContentType)) :-
215 current_prolog_flag(html_dialect, Dialect),
216 dialect_content_type_flag(Dialect, Flag),
217 current_prolog_flag(Flag, ContentType).
218
219dialect_doctype_flag(html4, html4_doctype).
220dialect_doctype_flag(html5, html5_doctype).
221dialect_doctype_flag(xhtml, xhtml_doctype).
222
223dialect_content_type_flag(html4, html4_content_type).
224dialect_content_type_flag(html5, html5_content_type).
225dialect_content_type_flag(xhtml, xhtml_content_type).
226
227option_default(html_dialect, html5).
228option_default(html4_doctype,
229 'HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" \c
230 "http://www.w3.org/TR/html4/loose.dtd"').
231option_default(html5_doctype,
232 'html').
233option_default(xhtml_doctype,
234 'html PUBLIC "-//W3C//DTD XHTML 1.0 \c
235 Transitional//EN" \c
236 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"').
237option_default(html4_content_type, 'text/html; charset=UTF-8').
238option_default(html5_content_type, 'text/html; charset=UTF-8').
239option_default(xhtml_content_type, 'application/xhtml+xml; charset=UTF-8').
240
244
245init_options :-
246 ( option_default(Name, Value),
247 ( current_prolog_flag(Name, _)
248 -> true
249 ; create_prolog_flag(Name, Value, [])
250 ),
251 fail
252 ; true
253 ).
254
255:- init_options. 256
260
('<?xml version=\'1.0\' encoding=\'UTF-8\'?>').
262
266
267ns(xhtml, 'http://www.w3.org/1999/xhtml').
268
269
270 273
280
281page(Content) -->
282 doctype,
283 html(html(Content)).
284
285page(Head, Body) -->
286 page(default, Head, Body).
287
288page(Style, Head, Body) -->
289 doctype,
290 content_type,
291 html_begin(html),
292 pagehead(Style, Head),
293 pagebody(Style, Body),
294 html_end(html).
295
302
303doctype -->
304 { html_current_option(doctype(DocType)),
305 DocType \== ''
306 },
307 !,
308 [ '<!DOCTYPE ', DocType, '>' ].
309doctype -->
310 [].
311
312content_type -->
313 { html_current_option(content_type(Type))
314 },
315 !,
316 html_post(head, meta([ 'http-equiv'('content-type'),
317 content(Type)
318 ], [])).
319content_type -->
320 { html_current_option(dialect(html5)) },
321 !,
322 html_post(head, meta('charset=UTF-8')).
323content_type -->
324 [].
325
326pagehead(_, Head) -->
327 { functor(Head, head, _)
328 },
329 !,
330 html(Head).
331pagehead(Style, Head) -->
332 { strip_module(Head, M, _),
333 hook_module(M, HM, head//2)
334 },
335 HM:head(Style, Head),
336 !.
337pagehead(_, Head) -->
338 { strip_module(Head, M, _),
339 hook_module(M, HM, head//1)
340 },
341 HM:head(Head),
342 !.
343pagehead(_, Head) -->
344 html(head(Head)).
345
346
347pagebody(_, Body) -->
348 { functor(Body, body, _)
349 },
350 !,
351 html(Body).
352pagebody(Style, Body) -->
353 { strip_module(Body, M, _),
354 hook_module(M, HM, body//2)
355 },
356 HM:body(Style, Body),
357 !.
358pagebody(_, Body) -->
359 { strip_module(Body, M, _),
360 hook_module(M, HM, body//1)
361 },
362 HM:body(Body),
363 !.
364pagebody(_, Body) -->
365 html(body(Body)).
366
367
368hook_module(M, M, PI) :-
369 current_predicate(M:PI),
370 !.
371hook_module(_, user, PI) :-
372 current_predicate(user:PI).
373
378
379html(Spec) -->
380 { strip_module(Spec, M, T) },
381 qhtml(T, M).
382
383qhtml(Var, _) -->
384 { var(Var),
385 !,
386 instantiation_error(Var)
387 }.
388qhtml([], _) -->
389 !,
390 [].
391qhtml([H|T], M) -->
392 !,
393 html_expand(H, M),
394 qhtml(T, M).
395qhtml(X, M) -->
396 html_expand(X, M).
397
398html_expand(Var, _) -->
399 { var(Var),
400 !,
401 instantiation_error(Var)
402 }.
403html_expand(Term, Module) -->
404 do_expand(Term, Module),
405 !.
406html_expand(Term, _Module) -->
407 { print_message(error, html(expand_failed(Term))) }.
408
409
410do_expand(Token, _) --> 411 expand(Token),
412 !.
413do_expand(Fmt-Args, _) -->
414 !,
415 { format(string(String), Fmt, Args)
416 },
417 html_quoted(String).
418do_expand(\List, Module) -->
419 { is_list(List)
420 },
421 !,
422 raw(List, Module).
423do_expand(\Term, Module, In, Rest) :-
424 !,
425 call(Module:Term, In, Rest).
426do_expand(Module:Term, _) -->
427 !,
428 qhtml(Term, Module).
429do_expand(&(Entity), _) -->
430 !,
431 { integer(Entity)
432 -> format(string(String), '&#~d;', [Entity])
433 ; format(string(String), '&~w;', [Entity])
434 },
435 [ String ].
436do_expand(Token, _) -->
437 { atomic(Token)
438 },
439 !,
440 html_quoted(Token).
441do_expand(element(Env, Attributes, Contents), M) -->
442 !,
443 ( { Contents == [],
444 html_current_option(dialect(xhtml))
445 }
446 -> xhtml_empty(Env, Attributes)
447 ; html_begin(Env, Attributes),
448 qhtml(Env, Contents, M),
449 html_end(Env)
450 ).
451do_expand(Term, M) -->
452 { Term =.. [Env, Contents]
453 },
454 !,
455 ( { layout(Env, _, empty)
456 }
457 -> html_begin(Env, Contents)
458 ; ( { Contents == [],
459 html_current_option(dialect(xhtml))
460 }
461 -> xhtml_empty(Env, [])
462 ; html_begin(Env),
463 qhtml(Env, Contents, M),
464 html_end(Env)
465 )
466 ).
467do_expand(Term, M) -->
468 { Term =.. [Env, Attributes, Contents],
469 check_non_empty(Contents, Env, Term)
470 },
471 !,
472 ( { Contents == [],
473 html_current_option(dialect(xhtml))
474 }
475 -> xhtml_empty(Env, Attributes)
476 ; html_begin(Env, Attributes),
477 qhtml(Env, Contents, M),
478 html_end(Env)
479 ).
480
481qhtml(Env, Contents, M) -->
482 { cdata_element(Env),
483 phrase(cdata(Contents, M), Tokens)
484 },
485 !,
486 [ cdata(Env, Tokens) ].
487qhtml(_, Contents, M) -->
488 qhtml(Contents, M).
489
490
491check_non_empty([], _, _) :- !.
492check_non_empty(_, Tag, Term) :-
493 layout(Tag, _, empty),
494 !,
495 print_message(warning,
496 format('Using empty element with content: ~p', [Term])).
497check_non_empty(_, _, _).
498
499cdata(List, M) -->
500 { is_list(List) },
501 !,
502 raw(List, M).
503cdata(One, M) -->
504 raw_element(One, M).
505
509
510raw([], _) -->
511 [].
512raw([H|T], Module) -->
513 raw_element(H, Module),
514 raw(T, Module).
515
516raw_element(Var, _) -->
517 { var(Var),
518 !,
519 instantiation_error(Var)
520 }.
521raw_element(\List, Module) -->
522 { is_list(List)
523 },
524 !,
525 raw(List, Module).
526raw_element(\Term, Module, In, Rest) :-
527 !,
528 call(Module:Term, In, Rest).
529raw_element(Module:Term, _) -->
530 !,
531 raw_element(Term, Module).
532raw_element(Fmt-Args, _) -->
533 !,
534 { format(string(S), Fmt, Args) },
535 [S].
536raw_element(Value, _) -->
537 { must_be(atomic, Value) },
538 [Value].
539
540
558
559html_begin(Env) -->
560 { Env =.. [Name|Attributes]
561 },
562 html_begin(Name, Attributes).
563
564html_begin(Env, Attributes) -->
565 pre_open(Env),
566 [<],
567 [Env],
568 attributes(Env, Attributes),
569 ( { layout(Env, _, empty),
570 html_current_option(dialect(xhtml))
571 }
572 -> ['/>']
573 ; [>]
574 ),
575 post_open(Env).
576
577html_end(Env) --> 578 { layout(Env, _, -),
579 html_current_option(dialect(html))
580 ; layout(Env, _, empty)
581 },
582 !,
583 [].
584html_end(Env) -->
585 pre_close(Env),
586 ['</'],
587 [Env],
588 ['>'],
589 post_close(Env).
590
594
595xhtml_empty(Env, Attributes) -->
596 pre_open(Env),
597 [<],
598 [Env],
599 attributes(Attributes),
600 ['/>'].
601
624
625xhtml_ns(Id, Value) -->
626 { html_current_option(dialect(xhtml)) },
627 !,
628 html_post(xmlns, \attribute(xmlns:Id=Value)).
629xhtml_ns(_, _) -->
630 [].
631
642
643html_root_attribute(Name, Value) -->
644 html_post(html_begin, \attribute(Name=Value)).
645
650
651attributes(html, L) -->
652 !,
653 ( { html_current_option(dialect(xhtml)) }
654 -> ( { option(xmlns(_), L) }
655 -> attributes(L)
656 ; { ns(xhtml, NS) },
657 attributes([xmlns(NS)|L])
658 ),
659 html_receive(xmlns)
660 ; attributes(L),
661 html_noreceive(xmlns)
662 ),
663 html_receive(html_begin).
664attributes(_, L) -->
665 attributes(L).
666
667attributes([]) -->
668 !,
669 [].
670attributes([H|T]) -->
671 !,
672 attribute(H),
673 attributes(T).
674attributes(One) -->
675 attribute(One).
676
677attribute(Name=Value) -->
678 !,
679 [' '], name(Name), [ '="' ],
680 attribute_value(Value),
681 ['"'].
682attribute(NS:Term) -->
683 !,
684 { Term =.. [Name, Value]
685 },
686 !,
687 attribute((NS:Name)=Value).
688attribute(Term) -->
689 { Term =.. [Name, Value]
690 },
691 !,
692 attribute(Name=Value).
693attribute(Atom) --> 694 { atom(Atom)
695 },
696 [ ' ', Atom ].
697
698name(NS:Name) -->
699 !,
700 [NS, :, Name].
701name(Name) -->
702 [ Name ].
703
723
724attribute_value(List) -->
725 { is_list(List) },
726 !,
727 attribute_value_m(List).
728attribute_value(Value) -->
729 attribute_value_s(Value).
730
732
733attribute_value_s(Var) -->
734 { var(Var),
735 !,
736 instantiation_error(Var)
737 }.
738attribute_value_s(A+B) -->
739 !,
740 attribute_value(A),
741 ( { is_list(B) }
742 -> ( { B == [] }
743 -> []
744 ; [?], search_parameters(B)
745 )
746 ; attribute_value(B)
747 ).
748attribute_value_s(encode(Value)) -->
749 !,
750 { uri_encoded(query_value, Value, Encoded) },
751 [ Encoded ].
752attribute_value_s(Value) -->
753 expand_attribute_value(Value),
754 !.
755attribute_value_s(Fmt-Args) -->
756 !,
757 { format(string(Value), Fmt, Args) },
758 html_quoted_attribute(Value).
759attribute_value_s(Value) -->
760 html_quoted_attribute(Value).
761
762search_parameters([H|T]) -->
763 search_parameter(H),
764 ( {T == []}
765 -> []
766 ; ['&'],
767 search_parameters(T)
768 ).
769
770search_parameter(Var) -->
771 { var(Var),
772 !,
773 instantiation_error(Var)
774 }.
775search_parameter(Name=Value) -->
776 { www_form_encode(Value, Encoded) },
777 [Name, =, Encoded].
778search_parameter(Term) -->
779 { Term =.. [Name, Value],
780 !,
781 www_form_encode(Value, Encoded)
782 },
783 [Name, =, Encoded].
784search_parameter(Term) -->
785 { domain_error(search_parameter, Term)
786 }.
787
797
798attribute_value_m([]) -->
799 [].
800attribute_value_m([H|T]) -->
801 attribute_value_s(H),
802 ( { T == [] }
803 -> []
804 ; [' '],
805 attribute_value_m(T)
806 ).
807
808
809 812
825
826html_quoted(Text) -->
827 { xml_quote_cdata(Text, Quoted, utf8) },
828 [ Quoted ].
829
838
839html_quoted_attribute(Text) -->
840 { xml_quote_attribute(Text, Quoted, utf8) },
841 [ Quoted ].
842
847
848cdata_element(script).
849cdata_element(style).
850
851
852 855
885
886html_post(Id, Content) -->
887 { strip_module(Content, M, C) },
888 [ mailbox(Id, post(M, C)) ].
889
900
901html_receive(Id) -->
902 html_receive(Id, sorted_html).
903
920
921html_receive(Id, Handler) -->
922 { strip_module(Handler, M, P) },
923 [ mailbox(Id, accept(M:P, _)) ].
924
928
929html_noreceive(Id) -->
930 [ mailbox(Id, ignore(_,_)) ].
931
940
941mailman(Tokens) :-
942 ( html_token(mailbox(_, accept(_, Accepted)), Tokens)
943 -> true
944 ),
945 var(Accepted), 946 !,
947 mailboxes(Tokens, Boxes),
948 keysort(Boxes, Keyed),
949 group_pairs_by_key(Keyed, PerKey),
950 move_last(PerKey, script, PerKey1),
951 move_last(PerKey1, head, PerKey2),
952 ( permutation(PerKey2, PerKeyPerm),
953 ( mail_ids(PerKeyPerm)
954 -> !
955 ; debug(html(mailman),
956 'Failed mail delivery order; retrying', []),
957 fail
958 )
959 -> true
960 ; print_message(error, html(cyclic_mailboxes))
961 ).
962mailman(_).
963
964move_last(Box0, Id, Box) :-
965 selectchk(Id-List, Box0, Box1),
966 !,
967 append(Box1, [Id-List], Box).
968move_last(Box, _, Box).
969
974
975html_token(Token, [H|T]) :-
976 html_token_(T, H, Token).
977
978html_token_(_, Token, Token) :- !.
979html_token_(_, cdata(_,Tokens), Token) :-
980 html_token(Token, Tokens).
981html_token_([H|T], _, Token) :-
982 html_token_(T, H, Token).
983
987
988mailboxes(Tokens, MailBoxes) :-
989 mailboxes(Tokens, MailBoxes, []).
990
991mailboxes([], List, List).
992mailboxes([mailbox(Id, Value)|T0], [Id-Value|T], Tail) :-
993 !,
994 mailboxes(T0, T, Tail).
995mailboxes([cdata(_Type, Tokens)|T0], Boxes, Tail) :-
996 !,
997 mailboxes(Tokens, Boxes, Tail0),
998 mailboxes(T0, Tail0, Tail).
999mailboxes([_|T0], T, Tail) :-
1000 mailboxes(T0, T, Tail).
1001
1002mail_ids([]).
1003mail_ids([H|T0]) :-
1004 mail_id(H, NewPosts),
1005 add_new_posts(NewPosts, T0, T),
1006 mail_ids(T).
1007
1008mail_id(Id-List, NewPosts) :-
1009 mail_handlers(List, Boxes, Content),
1010 ( Boxes = [accept(MH:Handler, In)]
1011 -> extend_args(Handler, Content, Goal),
1012 phrase(MH:Goal, In),
1013 mailboxes(In, NewBoxes),
1014 keysort(NewBoxes, Keyed),
1015 group_pairs_by_key(Keyed, NewPosts)
1016 ; Boxes = [ignore(_, _)|_]
1017 -> NewPosts = []
1018 ; Boxes = [accept(_,_),accept(_,_)|_]
1019 -> print_message(error, html(multiple_receivers(Id))),
1020 NewPosts = []
1021 ; print_message(error, html(no_receiver(Id))),
1022 NewPosts = []
1023 ).
1024
1025add_new_posts([], T, T).
1026add_new_posts([Id-Posts|NewT], T0, T) :-
1027 ( select(Id-List0, T0, Id-List, T1)
1028 -> append(List0, Posts, List)
1029 ; debug(html(mailman), 'Stuck with new posts on ~q', [Id]),
1030 fail
1031 ),
1032 add_new_posts(NewT, T1, T).
1033
1034
1040
1041mail_handlers([], [], []).
1042mail_handlers([post(Module,HTML)|T0], H, [Module:HTML|T]) :-
1043 !,
1044 mail_handlers(T0, H, T).
1045mail_handlers([H|T0], [H|T], C) :-
1046 mail_handlers(T0, T, C).
1047
1048extend_args(Term, Extra, NewTerm) :-
1049 Term =.. [Name|Args],
1050 append(Args, [Extra], NewArgs),
1051 NewTerm =.. [Name|NewArgs].
1052
1061
1062sorted_html(List) -->
1063 { sort(List, Unique) },
1064 html(Unique).
1065
1076
1077head_html(List) -->
1078 { list_to_set(List, Unique),
1079 html_expand_head(Unique, NewList)
1080 },
1081 html(NewList).
1082
1083:- multifile
1084 html_head_expansion/2. 1085
1086html_expand_head(List0, List) :-
1087 html_head_expansion(List0, List1),
1088 List0 \== List1,
1089 !,
1090 html_expand_head(List1, List).
1091html_expand_head(List, List).
1092
1093
1094 1097
1098pre_open(Env) -->
1099 { layout(Env, N-_, _)
1100 },
1101 !,
1102 [ nl(N) ].
1103pre_open(_) --> [].
1104
1105post_open(Env) -->
1106 { layout(Env, _-N, _)
1107 },
1108 !,
1109 [ nl(N) ].
1110post_open(_) -->
1111 [].
1112
1113pre_close(head) -->
1114 !,
1115 html_receive(head, head_html),
1116 { layout(head, _, N-_) },
1117 [ nl(N) ].
1118pre_close(Env) -->
1119 { layout(Env, _, N-_)
1120 },
1121 !,
1122 [ nl(N) ].
1123pre_close(_) -->
1124 [].
1125
1126post_close(Env) -->
1127 { layout(Env, _, _-N)
1128 },
1129 !,
1130 [ nl(N) ].
1131post_close(_) -->
1132 [].
1133
1148
1149:- multifile
1150 layout/3. 1151
1152layout(table, 2-1, 1-2).
1153layout(blockquote, 2-1, 1-2).
1154layout(pre, 2-1, 0-2).
1155layout(textarea, 1-1, 0-1).
1156layout(center, 2-1, 1-2).
1157layout(dl, 2-1, 1-2).
1158layout(ul, 1-1, 1-1).
1159layout(ol, 2-1, 1-2).
1160layout(form, 2-1, 1-2).
1161layout(frameset, 2-1, 1-2).
1162layout(address, 2-1, 1-2).
1163
1164layout(head, 1-1, 1-1).
1165layout(body, 1-1, 1-1).
1166layout(script, 1-1, 1-1).
1167layout(style, 1-1, 1-1).
1168layout(select, 1-1, 1-1).
1169layout(map, 1-1, 1-1).
1170layout(html, 1-1, 1-1).
1171layout(caption, 1-1, 1-1).
1172layout(applet, 1-1, 1-1).
1173
1174layout(tr, 1-0, 0-1).
1175layout(option, 1-0, 0-1).
1176layout(li, 1-0, 0-1).
1177layout(dt, 1-0, -).
1178layout(dd, 0-0, -).
1179layout(title, 1-0, 0-1).
1180
1181layout(h1, 2-0, 0-2).
1182layout(h2, 2-0, 0-2).
1183layout(h3, 2-0, 0-2).
1184layout(h4, 2-0, 0-2).
1185
1186layout(iframe, 1-1, 1-1).
1187
1188layout(hr, 1-1, empty). 1189layout(br, 0-1, empty).
1190layout(img, 0-0, empty).
1191layout(meta, 1-1, empty).
1192layout(base, 1-1, empty).
1193layout(link, 1-1, empty).
1194layout(input, 0-0, empty).
1195layout(frame, 1-1, empty).
1196layout(col, 0-0, empty).
1197layout(area, 1-0, empty).
1198layout(input, 1-0, empty).
1199layout(param, 1-0, empty).
1200
1201layout(p, 2-1, -). 1202layout(td, 0-0, 0-0).
1203
1204layout(div, 1-0, 0-1).
1205
1206 1209
1222
1223print_html(List) :-
1224 current_output(Out),
1225 mailman(List),
1226 write_html(List, Out).
1227print_html(Out, List) :-
1228 ( html_current_option(dialect(xhtml))
1229 -> stream_property(Out, encoding(Enc)),
1230 ( Enc == utf8
1231 -> true
1232 ; print_message(warning, html(wrong_encoding(Out, Enc)))
1233 ),
1234 xml_header(Hdr),
1235 write(Out, Hdr), nl(Out)
1236 ; true
1237 ),
1238 mailman(List),
1239 write_html(List, Out),
1240 flush_output(Out).
1241
1242write_html([], _).
1243write_html([nl(N)|T], Out) :-
1244 !,
1245 join_nl(T, N, Lines, T2),
1246 write_nl(Lines, Out),
1247 write_html(T2, Out).
1248write_html([mailbox(_, Box)|T], Out) :-
1249 !,
1250 ( Box = accept(_, Accepted)
1251 -> write_html(Accepted, Out)
1252 ; true
1253 ),
1254 write_html(T, Out).
1255write_html([cdata(Env, Tokens)|T], Out) :-
1256 !,
1257 with_output_to(string(CDATA), write_html(Tokens, current_output)),
1258 valid_cdata(Env, CDATA),
1259 write(Out, CDATA),
1260 write_html(T, Out).
1261write_html([H|T], Out) :-
1262 write(Out, H),
1263 write_html(T, Out).
1264
1265join_nl([nl(N0)|T0], N1, N, T) :-
1266 !,
1267 N2 is max(N0, N1),
1268 join_nl(T0, N2, N, T).
1269join_nl(L, N, N, L).
1270
1271write_nl(0, _) :- !.
1272write_nl(N, Out) :-
1273 nl(Out),
1274 N1 is N - 1,
1275 write_nl(N1, Out).
1276
1288
1289valid_cdata(Env, String) :-
1290 atomics_to_string(['</', Env, '>'], End),
1291 sub_atom_icasechk(String, _, End),
1292 !,
1293 domain_error(cdata, String).
1294valid_cdata(_, _).
1295
1309
1310html_print_length(List, Len) :-
1311 mailman(List),
1312 ( html_current_option(dialect(xhtml))
1313 -> xml_header(Hdr),
1314 atom_length(Hdr, L0),
1315 L1 is L0+1 1316 ; L1 = 0
1317 ),
1318 html_print_length(List, L1, Len).
1319
1320html_print_length([], L, L).
1321html_print_length([nl(N)|T], L0, L) :-
1322 !,
1323 join_nl(T, N, Lines, T1),
1324 L1 is L0 + Lines, 1325 html_print_length(T1, L1, L).
1326html_print_length([mailbox(_, Box)|T], L0, L) :-
1327 !,
1328 ( Box = accept(_, Accepted)
1329 -> html_print_length(Accepted, L0, L1)
1330 ; L1 = L0
1331 ),
1332 html_print_length(T, L1, L).
1333html_print_length([cdata(_, CDATA)|T], L0, L) :-
1334 !,
1335 html_print_length(CDATA, L0, L1),
1336 html_print_length(T, L1, L).
1337html_print_length([H|T], L0, L) :-
1338 atom_length(H, Hlen),
1339 L1 is L0+Hlen,
1340 html_print_length(T, L1, L).
1341
1342
1349
1350reply_html_page(Head, Body) :-
1351 reply_html_page(default, Head, Body).
1352reply_html_page(Style, Head, Body) :-
1353 html_current_option(content_type(Type)),
1354 phrase(page(Style, Head, Body), HTML),
1355 forall(html_header_hook(Style), true),
1356 format('Content-type: ~w~n~n', [Type]),
1357 print_html(HTML).
1358
1359
1365
1366
1367
1368 1371
1385
1386html_meta(Spec) :-
1387 throw(error(context_error(nodirective, html_meta(Spec)), _)).
1388
1389html_meta_decls(Var, _, _) :-
1390 var(Var),
1391 !,
1392 instantiation_error(Var).
1393html_meta_decls((A,B), (MA,MB), [MH|T]) :-
1394 !,
1395 html_meta_decl(A, MA, MH),
1396 html_meta_decls(B, MB, T).
1397html_meta_decls(A, MA, [MH]) :-
1398 html_meta_decl(A, MA, MH).
1399
1400html_meta_decl(Head, MetaHead,
1401 html_write:html_meta_head(GenHead, Module, Head)) :-
1402 functor(Head, Name, Arity),
1403 functor(GenHead, Name, Arity),
1404 prolog_load_context(module, Module),
1405 Head =.. [Name|HArgs],
1406 maplist(html_meta_decl, HArgs, MArgs),
1407 MetaHead =.. [Name|MArgs].
1408
1409html_meta_decl(html, :) :- !.
1410html_meta_decl(Meta, Meta).
1411
1412system:term_expansion((:- html_meta(Heads)),
1413 [ (:- meta_predicate(Meta))
1414 | MetaHeads
1415 ]) :-
1416 html_meta_decls(Heads, Meta, MetaHeads).
1417
1418:- multifile
1419 html_meta_head/3. 1420
1421html_meta_colours(Head, Goal, built_in-Colours) :-
1422 Head =.. [_|MArgs],
1423 Goal =.. [_|Args],
1424 maplist(meta_colours, MArgs, Args, Colours).
1425
1426meta_colours(html, HTML, Colours) :-
1427 !,
1428 html_colours(HTML, Colours).
1429meta_colours(I, _, Colours) :-
1430 integer(I), I>=0,
1431 !,
1432 Colours = meta(I).
1433meta_colours(_, _, classify).
1434
1435html_meta_called(Head, Goal, Called) :-
1436 Head =.. [_|MArgs],
1437 Goal =.. [_|Args],
1438 meta_called(MArgs, Args, Called, []).
1439
1440meta_called([], [], Called, Called).
1441meta_called([html|MT], [A|AT], Called, Tail) :-
1442 !,
1443 phrase(called_by(A), Called, Tail1),
1444 meta_called(MT, AT, Tail1, Tail).
1445meta_called([0|MT], [A|AT], [A|CT0], CT) :-
1446 !,
1447 meta_called(MT, AT, CT0, CT).
1448meta_called([I|MT], [A|AT], [A+I|CT0], CT) :-
1449 integer(I), I>0,
1450 !,
1451 meta_called(MT, AT, CT0, CT).
1452meta_called([_|MT], [_|AT], Called, Tail) :-
1453 !,
1454 meta_called(MT, AT, Called, Tail).
1455
1456
1457:- html_meta
1458 html(html,?,?),
1459 page(html,?,?),
1460 page(html,html,?,?),
1461 page(+,html,html,?,?),
1462 pagehead(+,html,?,?),
1463 pagebody(+,html,?,?),
1464 reply_html_page(html,html),
1465 reply_html_page(+,html,html),
1466 html_post(+,html,?,?). 1467
1468
1469 1472
1473:- multifile
1474 prolog_colour:goal_colours/2,
1475 prolog_colour:style/2,
1476 prolog_colour:message//1,
1477 prolog:called_by/2. 1478
1479prolog_colour:goal_colours(Goal, Colours) :-
1480 html_meta_head(Goal, _Module, Head),
1481 html_meta_colours(Head, Goal, Colours).
1482prolog_colour:goal_colours(html_meta(_),
1483 built_in-[meta_declarations([html])]).
1484
1485 1486html_colours(Var, classify) :-
1487 var(Var),
1488 !.
1489html_colours(\List, html_raw-[list-Colours]) :-
1490 is_list(List),
1491 !,
1492 list_colours(List, Colours).
1493html_colours(\_, html_call-[dcg]) :- !.
1494html_colours(_:Term, built_in-[classify,Colours]) :-
1495 !,
1496 html_colours(Term, Colours).
1497html_colours(&(Entity), functor-[entity(Entity)]) :- !.
1498html_colours(List, list-ListColours) :-
1499 List = [_|_],
1500 !,
1501 list_colours(List, ListColours).
1502html_colours(Format-Args, functor-[FormatColor,ArgsColors]) :-
1503 !,
1504 format_colours(Format, FormatColor),
1505 format_arg_colours(Args, Format, ArgsColors).
1506html_colours(Term, TermColours) :-
1507 compound(Term),
1508 compound_name_arguments(Term, Name, Args),
1509 Name \== '.',
1510 !,
1511 ( Args = [One]
1512 -> TermColours = html(Name)-ArgColours,
1513 ( layout(Name, _, empty)
1514 -> attr_colours(One, ArgColours)
1515 ; html_colours(One, Colours),
1516 ArgColours = [Colours]
1517 )
1518 ; Args = [AList,Content]
1519 -> TermColours = html(Name)-[AColours, Colours],
1520 attr_colours(AList, AColours),
1521 html_colours(Content, Colours)
1522 ; TermColours = error
1523 ).
1524html_colours(_, classify).
1525
1526list_colours(Var, classify) :-
1527 var(Var),
1528 !.
1529list_colours([], []).
1530list_colours([H0|T0], [H|T]) :-
1531 !,
1532 html_colours(H0, H),
1533 list_colours(T0, T).
1534list_colours(Last, Colours) :- 1535 html_colours(Last, Colours).
1536
1537attr_colours(Var, classify) :-
1538 var(Var),
1539 !.
1540attr_colours([], classify) :- !.
1541attr_colours(Term, list-Elements) :-
1542 Term = [_|_],
1543 !,
1544 attr_list_colours(Term, Elements).
1545attr_colours(Name=Value, built_in-[html_attribute(Name), VColour]) :-
1546 !,
1547 attr_value_colour(Value, VColour).
1548attr_colours(NS:Term, built_in-[ html_xmlns(NS),
1549 html_attribute(Name)-[classify]
1550 ]) :-
1551 compound(Term),
1552 compound_name_arity(Term, Name, 1).
1553attr_colours(Term, html_attribute(Name)-[VColour]) :-
1554 compound(Term),
1555 compound_name_arity(Term, Name, 1),
1556 !,
1557 Term =.. [Name,Value],
1558 attr_value_colour(Value, VColour).
1559attr_colours(Name, html_attribute(Name)) :-
1560 atom(Name),
1561 !.
1562attr_colours(Term, classify) :-
1563 compound(Term),
1564 compound_name_arity(Term, '.', 2),
1565 !.
1566attr_colours(_, error).
1567
1568attr_list_colours(Var, classify) :-
1569 var(Var),
1570 !.
1571attr_list_colours([], []).
1572attr_list_colours([H0|T0], [H|T]) :-
1573 attr_colours(H0, H),
1574 attr_list_colours(T0, T).
1575
1576attr_value_colour(Var, classify) :-
1577 var(Var).
1578attr_value_colour(location_by_id(ID), sgml_attr_function-[Colour]) :-
1579 !,
1580 location_id(ID, Colour).
1581attr_value_colour(#(ID), sgml_attr_function-[Colour]) :-
1582 !,
1583 location_id(ID, Colour).
1584attr_value_colour(A+B, sgml_attr_function-[CA,CB]) :-
1585 !,
1586 attr_value_colour(A, CA),
1587 attr_value_colour(B, CB).
1588attr_value_colour(encode(_), sgml_attr_function-[classify]) :- !.
1589attr_value_colour(Atom, classify) :-
1590 atomic(Atom),
1591 !.
1592attr_value_colour([_|_], classify) :- !.
1593attr_value_colour(_Fmt-_Args, classify) :- !.
1594attr_value_colour(Term, classify) :-
1595 compound(Term),
1596 compound_name_arity(Term, '.', 2),
1597 !.
1598attr_value_colour(_, error).
1599
1600location_id(ID, classify) :-
1601 var(ID),
1602 !.
1603location_id(ID, Class) :-
1604 ( catch(http_location_by_id(ID, Location), _, fail)
1605 -> Class = http_location_for_id(Location)
1606 ; Class = http_no_location_for_id(ID)
1607 ).
1608location_id(_, classify).
1609
1610format_colours(Format, format_string) :- atom(Format), !.
1611format_colours(Format, format_string) :- string(Format), !.
1612format_colours(_Format, type_error(text)).
1613
1614format_arg_colours(Args, _Format, classify) :- is_list(Args), !.
1615format_arg_colours(_, _, type_error(list)).
1616
1617:- op(990, xfx, :=). 1618:- op(200, fy, @). 1619
1620prolog_colour:style(html(_), [colour(magenta4), bold(true)]).
1621prolog_colour:style(entity(_), [colour(magenta4)]).
1622prolog_colour:style(html_attribute(_), [colour(magenta4)]).
1623prolog_colour:style(html_xmlns(_), [colour(magenta4)]).
1624prolog_colour:style(format_string(_), [colour(magenta4)]).
1625prolog_colour:style(sgml_attr_function, [colour(blue)]).
1626prolog_colour:style(http_location_for_id(_), [bold(true)]).
1627prolog_colour:style(http_no_location_for_id(_), [colour(red), bold(true)]).
1628
1629
1630prolog_colour:message(html(Element)) -->
1631 [ '~w: SGML element'-[Element] ].
1632prolog_colour:message(entity(Entity)) -->
1633 [ '~w: SGML entity'-[Entity] ].
1634prolog_colour:message(html_attribute(Attr)) -->
1635 [ '~w: SGML attribute'-[Attr] ].
1636prolog_colour:message(sgml_attr_function) -->
1637 [ 'SGML Attribute function'-[] ].
1638prolog_colour:message(http_location_for_id(Location)) -->
1639 [ 'ID resolves to ~w'-[Location] ].
1640prolog_colour:message(http_no_location_for_id(ID)) -->
1641 [ '~w: no such ID'-[ID] ].
1642
1643
1648
1649
1650prolog:called_by(Goal, Called) :-
1651 html_meta_head(Goal, _Module, Head),
1652 html_meta_called(Head, Goal, Called).
1653
1654called_by(Term) -->
1655 called_by(Term, _).
1656
1657called_by(Var, _) -->
1658 { var(Var) },
1659 !,
1660 [].
1661called_by(\G, M) -->
1662 !,
1663 ( { is_list(G) }
1664 -> called_by(G, M)
1665 ; {atom(M)}
1666 -> [(M:G)+2]
1667 ; [G+2]
1668 ).
1669called_by([], _) -->
1670 !,
1671 [].
1672called_by([H|T], M) -->
1673 !,
1674 called_by(H, M),
1675 called_by(T, M).
1676called_by(M:Term, _) -->
1677 !,
1678 ( {atom(M)}
1679 -> called_by(Term, M)
1680 ; []
1681 ).
1682called_by(Term, M) -->
1683 { compound(Term),
1684 !,
1685 Term =.. [_|Args]
1686 },
1687 called_by(Args, M).
1688called_by(_, _) -->
1689 [].
1690
1691:- multifile
1692 prolog:hook/1. 1693
1694prolog:hook(body(_,_,_)).
1695prolog:hook(body(_,_,_,_)).
1696prolog:hook(head(_,_,_)).
1697prolog:hook(head(_,_,_,_)).
1698
1699
1700 1703
1704:- multifile
1705 prolog:message/3. 1706
1707prolog:message(html(expand_failed(What))) -->
1708 [ 'Failed to translate to HTML: ~p'-[What] ].
1709prolog:message(html(wrong_encoding(Stream, Enc))) -->
1710 [ 'XHTML demands UTF-8 encoding; encoding of ~p is ~w'-[Stream, Enc] ].
1711prolog:message(html(multiple_receivers(Id))) -->
1712 [ 'html_post//2: multiple receivers for: ~p'-[Id] ].
1713prolog:message(html(no_receiver(Id))) -->
1714 [ 'html_post//2: no receivers for: ~p'-[Id] ]