1/*  Part of SWI-Prolog
   2
   3    Author:        Jan Wielemaker and Anjo Anjewierden
   4    E-mail:        J.Wielemaker@vu.nl
   5    WWW:           http://www.swi-prolog.org
   6    Copyright (c)  2002-2015, 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(html_write,
  37          [ reply_html_page/2,          % :Head, :Body
  38            reply_html_page/3,          % +Style, :Head, :Body
  39
  40                                        % Basic output routines
  41            page//1,                    % :Content
  42            page//2,                    % :Head, :Body
  43            page//3,                    % +Style, :Head, :Body
  44            html//1,                    % :Content
  45
  46                                        % Option processing
  47            html_set_options/1,         % +OptionList
  48            html_current_option/1,      % ?Option
  49
  50                                        % repositioning HTML elements
  51            html_post//2,               % +Id, :Content
  52            html_receive//1,            % +Id
  53            html_receive//2,            % +Id, :Handler
  54            xhtml_ns//2,                % +Id, +Value
  55            html_root_attribute//2,     % +Name, +Value
  56
  57            html/4,                     % <![html[quasi quotations]]>
  58
  59                                        % Useful primitives for expanding
  60            html_begin//1,              % +EnvName[(Attribute...)]
  61            html_end//1,                % +EnvName
  62            html_quoted//1,             % +Text
  63            html_quoted_attribute//1,   % +Attribute
  64
  65                                        % Emitting the HTML code
  66            print_html/1,               % +List
  67            print_html/2,               % +Stream, +List
  68            html_print_length/2,        % +List, -Length
  69
  70                                        % Extension support
  71            (html_meta)/1,              % +Spec
  72            op(1150, fx, html_meta)
  73          ]).
  74:- use_module(library(error)).
  75:- use_module(library(apply)).
  76:- use_module(library(lists)).
  77:- use_module(library(option)).
  78:- use_module(library(pairs)).
  79:- use_module(library(sgml)).           % Quote output
  80:- use_module(library(uri)).
  81:- use_module(library(debug)).
  82:- use_module(html_quasiquotations).
  83:- use_module(library(http/http_dispatch), [http_location_by_id/2]).
  84
  85:- set_prolog_flag(generate_debug_info, false).
  86
  87:- meta_predicate
  88    reply_html_page(+, :, :),
  89    reply_html_page(:, :),
  90    html(:, -, +),
  91    page(:, -, +),
  92    page(:, :, -, +),
  93    pagehead(+, :, -, +),
  94    pagebody(+, :, -, +),
  95    html_receive(+, 3, -, +),
  96    html_post(+, :, -, +).
  97
  98:- multifile
  99    expand//1,                      % +HTMLElement
 100    expand_attribute_value//1.      % +HTMLAttributeValue
 101
 102
 103/** <module> Write HTML text
 104
 105The purpose of this library  is  to   simplify  writing  HTML  pages. Of
 106course, it is possible to  use  format/3   to  write  to the HTML stream
 107directly, but this is generally not very satisfactory:
 108
 109        * It is a lot of typing
 110        * It does not guarantee proper HTML syntax.  You have to deal
 111          with HTML quoting, proper nesting and reasonable layout.
 112        * It is hard to use satisfactory abstraction
 113
 114This module tries to remedy these problems.   The idea is to translate a
 115Prolog term into  an  HTML  document.  We   use  DCG  for  most  of  the
 116generation.
 117
 118---++ International documents
 119
 120The library supports the generation of international documents, but this
 121is currently limited to using UTF-8 encoded HTML or XHTML documents.  It
 122is strongly recommended to use the following mime-type.
 123
 124==
 125Content-type: text/html; charset=UTF-8
 126==
 127
 128When generating XHTML documents, the output stream must be in UTF-8
 129encoding.
 130*/
 131
 132
 133                 /*******************************
 134                 *            SETTINGS          *
 135                 *******************************/
 136
 137%!  html_set_options(+Options) is det.
 138%
 139%   Set options for the HTML output.   Options  are stored in prolog
 140%   flags to ensure proper multi-threaded behaviour where setting an
 141%   option is local to the thread  and   new  threads start with the
 142%   options from the parent thread. Defined options are:
 143%
 144%     * dialect(Dialect)
 145%       One of =html4=, =xhtml= or =html5= (default). For
 146%       compatibility reasons, =html= is accepted as an
 147%       alias for =html4=.
 148%
 149%     * doctype(+DocType)
 150%       Set the =|<|DOCTYPE|= DocType =|>|= line for page//1 and
 151%       page//2.
 152%
 153%     * content_type(+ContentType)
 154%       Set the =|Content-type|= for reply_html_page/3
 155%
 156%   Note that the doctype and  content_type   flags  are  covered by
 157%   distinct  prolog  flags:  =html4_doctype=,  =xhtml_doctype=  and
 158%   =html5_doctype= and similar for the   content  type. The Dialect
 159%   must be switched before doctype and content type.
 160
 161html_set_options(Options) :-
 162    must_be(list, Options),
 163    set_options(Options).
 164
 165set_options([]).
 166set_options([H|T]) :-
 167    html_set_option(H),
 168    set_options(T).
 169
 170html_set_option(dialect(Dialect0)) :-
 171    !,
 172    must_be(oneof([html,html4,xhtml,html5]), Dialect0),
 173    (   html_version_alias(Dialect0, Dialect)
 174    ->  true
 175    ;   Dialect = Dialect0
 176    ),
 177    set_prolog_flag(html_dialect, Dialect).
 178html_set_option(doctype(Atom)) :-
 179    !,
 180    must_be(atom, Atom),
 181    current_prolog_flag(html_dialect, Dialect),
 182    dialect_doctype_flag(Dialect, Flag),
 183    set_prolog_flag(Flag, Atom).
 184html_set_option(content_type(Atom)) :-
 185    !,
 186    must_be(atom, Atom),
 187    current_prolog_flag(html_dialect, Dialect),
 188    dialect_content_type_flag(Dialect, Flag),
 189    set_prolog_flag(Flag, Atom).
 190html_set_option(O) :-
 191    domain_error(html_option, O).
 192
 193html_version_alias(html, html4).
 194
 195%!  html_current_option(?Option) is nondet.
 196%
 197%   True if Option is an active option for the HTML generator.
 198
 199html_current_option(dialect(Dialect)) :-
 200    current_prolog_flag(html_dialect, Dialect).
 201html_current_option(doctype(DocType)) :-
 202    current_prolog_flag(html_dialect, Dialect),
 203    dialect_doctype_flag(Dialect, Flag),
 204    current_prolog_flag(Flag, DocType).
 205html_current_option(content_type(ContentType)) :-
 206    current_prolog_flag(html_dialect, Dialect),
 207    dialect_content_type_flag(Dialect, Flag),
 208    current_prolog_flag(Flag, ContentType).
 209
 210dialect_doctype_flag(html4, html4_doctype).
 211dialect_doctype_flag(html5, html5_doctype).
 212dialect_doctype_flag(xhtml, xhtml_doctype).
 213
 214dialect_content_type_flag(html4, html4_content_type).
 215dialect_content_type_flag(html5, html5_content_type).
 216dialect_content_type_flag(xhtml, xhtml_content_type).
 217
 218option_default(html_dialect, html5).
 219option_default(html4_doctype,
 220               'HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" \c
 221               "http://www.w3.org/TR/html4/loose.dtd"').
 222option_default(html5_doctype,
 223               'html').
 224option_default(xhtml_doctype,
 225               'html PUBLIC "-//W3C//DTD XHTML 1.0 \c
 226               Transitional//EN" \c
 227               "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"').
 228option_default(html4_content_type, 'text/html; charset=UTF-8').
 229option_default(html5_content_type, 'text/html; charset=UTF-8').
 230option_default(xhtml_content_type, 'application/xhtml+xml; charset=UTF-8').
 231
 232%!  init_options is det.
 233%
 234%   Initialise the HTML processing options.
 235
 236init_options :-
 237    (   option_default(Name, Value),
 238        (   current_prolog_flag(Name, _)
 239        ->  true
 240        ;   create_prolog_flag(Name, Value, [])
 241        ),
 242        fail
 243    ;   true
 244    ).
 245
 246:- init_options.
 247
 248%!  xml_header(-Header)
 249%
 250%   First line of XHTML document.  Added by print_html/1.
 251
 252xml_header('<?xml version=\'1.0\' encoding=\'UTF-8\'?>').
 253
 254%!  ns(?Which, ?Atom)
 255%
 256%   Namespace declarations
 257
 258ns(xhtml, 'http://www.w3.org/1999/xhtml').
 259
 260
 261                 /*******************************
 262                 *             PAGE             *
 263                 *******************************/
 264
 265%!  page(+Content:dom)// is det.
 266%!  page(+Head:dom, +Body:dom)// is det.
 267%
 268%   Generate a page including the   HTML  =|<!DOCTYPE>|= header. The
 269%   actual doctype is read from the   option =doctype= as defined by
 270%   html_set_options/1.
 271
 272page(Content) -->
 273    doctype,
 274    html(html(Content)).
 275
 276page(Head, Body) -->
 277    page(default, Head, Body).
 278
 279page(Style, Head, Body) -->
 280    doctype,
 281    content_type,
 282    html_begin(html),
 283    pagehead(Style, Head),
 284    pagebody(Style, Body),
 285    html_end(html).
 286
 287%!  doctype//
 288%
 289%   Emit the =|<DOCTYPE ...|= header.  The   doctype  comes from the
 290%   option doctype(DOCTYPE) (see html_set_options/1).   Setting  the
 291%   doctype to '' (empty  atom)   suppresses  the header completely.
 292%   This is to avoid a IE bug in processing AJAX output ...
 293
 294doctype -->
 295    { html_current_option(doctype(DocType)),
 296      DocType \== ''
 297    },
 298    !,
 299    [ '<!DOCTYPE ', DocType, '>' ].
 300doctype -->
 301    [].
 302
 303content_type -->
 304    { html_current_option(content_type(Type))
 305    },
 306    !,
 307    html_post(head, meta([ 'http-equiv'('content-type'),
 308                           content(Type)
 309                         ], [])).
 310content_type -->
 311    { html_current_option(dialect(html5)) },
 312    !,
 313    html_post(head, meta('charset=UTF-8')).
 314content_type -->
 315    [].
 316
 317pagehead(_, Head) -->
 318    { functor(Head, head, _)
 319    },
 320    !,
 321    html(Head).
 322pagehead(Style, Head) -->
 323    { strip_module(Head, M, _),
 324      hook_module(M, HM, head//2)
 325    },
 326    HM:head(Style, Head),
 327    !.
 328pagehead(_, Head) -->
 329    { strip_module(Head, M, _),
 330      hook_module(M, HM, head//1)
 331    },
 332    HM:head(Head),
 333    !.
 334pagehead(_, Head) -->
 335    html(head(Head)).
 336
 337
 338pagebody(_, Body) -->
 339    { functor(Body, body, _)
 340    },
 341    !,
 342    html(Body).
 343pagebody(Style, Body) -->
 344    { strip_module(Body, M, _),
 345      hook_module(M, HM, body//2)
 346    },
 347    HM:body(Style, Body),
 348    !.
 349pagebody(_, Body) -->
 350    { strip_module(Body, M, _),
 351      hook_module(M, HM, body//1)
 352    },
 353    HM:body(Body),
 354    !.
 355pagebody(_, Body) -->
 356    html(body(Body)).
 357
 358
 359hook_module(M, M, PI) :-
 360    current_predicate(M:PI),
 361    !.
 362hook_module(_, user, PI) :-
 363    current_predicate(user:PI).
 364
 365%!  html(+Content:dom)// is det
 366%
 367%   Generate HTML from Content.  Generates a token sequence for
 368%   print_html/2.
 369
 370html(Spec) -->
 371    { strip_module(Spec, M, T) },
 372    qhtml(T, M).
 373
 374qhtml(Var, _) -->
 375    { var(Var),
 376      !,
 377      instantiation_error(Var)
 378    }.
 379qhtml([], _) -->
 380    !,
 381    [].
 382qhtml([H|T], M) -->
 383    !,
 384    html_expand(H, M),
 385    qhtml(T, M).
 386qhtml(X, M) -->
 387    html_expand(X, M).
 388
 389html_expand(Var, _) -->
 390    { var(Var),
 391      !,
 392      instantiation_error(Var)
 393    }.
 394html_expand(Term, Module) -->
 395    do_expand(Term, Module),
 396    !.
 397html_expand(Term, _Module) -->
 398    { print_message(error, html(expand_failed(Term))) }.
 399
 400
 401do_expand(Token, _) -->                 % call user hooks
 402    expand(Token),
 403    !.
 404do_expand(Fmt-Args, _) -->
 405    !,
 406    { format(string(String), Fmt, Args)
 407    },
 408    html_quoted(String).
 409do_expand(\List, Module) -->
 410    { is_list(List)
 411    },
 412    !,
 413    raw(List, Module).
 414do_expand(\Term, Module, In, Rest) :-
 415    !,
 416    call(Module:Term, In, Rest).
 417do_expand(Module:Term, _) -->
 418    !,
 419    qhtml(Term, Module).
 420do_expand(&(Entity), _) -->
 421    !,
 422    {   integer(Entity)
 423    ->  format(string(String), '&#~d;', [Entity])
 424    ;   format(string(String), '&~w;', [Entity])
 425    },
 426    [ String ].
 427do_expand(Token, _) -->
 428    { atomic(Token)
 429    },
 430    !,
 431    html_quoted(Token).
 432do_expand(element(Env, Attributes, Contents), M) -->
 433    !,
 434    (   { Contents == [],
 435          html_current_option(dialect(xhtml))
 436        }
 437    ->  xhtml_empty(Env, Attributes)
 438    ;   html_begin(Env, Attributes),
 439        qhtml(Env, Contents, M),
 440        html_end(Env)
 441    ).
 442do_expand(Term, M) -->
 443    { Term =.. [Env, Contents]
 444    },
 445    !,
 446    (   { layout(Env, _, empty)
 447        }
 448    ->  html_begin(Env, Contents)
 449    ;   (   { Contents == [],
 450              html_current_option(dialect(xhtml))
 451            }
 452        ->  xhtml_empty(Env, [])
 453        ;   html_begin(Env),
 454            qhtml(Env, Contents, M),
 455            html_end(Env)
 456        )
 457    ).
 458do_expand(Term, M) -->
 459    { Term =.. [Env, Attributes, Contents],
 460      check_non_empty(Contents, Env, Term)
 461    },
 462    !,
 463    (   { Contents == [],
 464          html_current_option(dialect(xhtml))
 465        }
 466    ->  xhtml_empty(Env, Attributes)
 467    ;   html_begin(Env, Attributes),
 468        qhtml(Env, Contents, M),
 469        html_end(Env)
 470    ).
 471
 472qhtml(Env, Contents, M) -->
 473    { cdata_element(Env),
 474      phrase(cdata(Contents, M), Tokens)
 475    },
 476    !,
 477    [ cdata(Env, Tokens) ].
 478qhtml(_, Contents, M) -->
 479    qhtml(Contents, M).
 480
 481
 482check_non_empty([], _, _) :- !.
 483check_non_empty(_, Tag, Term) :-
 484    layout(Tag, _, empty),
 485    !,
 486    print_message(warning,
 487                  format('Using empty element with content: ~p', [Term])).
 488check_non_empty(_, _, _).
 489
 490cdata(List, M) -->
 491    { is_list(List) },
 492    !,
 493    raw(List, M).
 494cdata(One, M) -->
 495    raw_element(One, M).
 496
 497%!  raw(+List, +Module)// is det.
 498%
 499%   Emit unquoted (raw) output used for scripts, etc.
 500
 501raw([], _) -->
 502    [].
 503raw([H|T], Module) -->
 504    raw_element(H, Module),
 505    raw(T, Module).
 506
 507raw_element(Var, _) -->
 508    { var(Var),
 509      !,
 510      instantiation_error(Var)
 511    }.
 512raw_element(\List, Module) -->
 513    { is_list(List)
 514    },
 515    !,
 516    raw(List, Module).
 517raw_element(\Term, Module, In, Rest) :-
 518    !,
 519    call(Module:Term, In, Rest).
 520raw_element(Module:Term, _) -->
 521    !,
 522    raw_element(Term, Module).
 523raw_element(Fmt-Args, _) -->
 524    !,
 525    { format(string(S), Fmt, Args) },
 526    [S].
 527raw_element(Value, _) -->
 528    { must_be(atomic, Value) },
 529    [Value].
 530
 531
 532%!  html_begin(+Env)// is det.
 533%!  html_end(+End)// is det
 534%
 535%   For  html_begin//1,  Env  is   a    term   Env(Attributes);  for
 536%   html_end//1  it  is  the  plain    environment  name.  Used  for
 537%   exceptional  cases.  Normal  applications    use   html//1.  The
 538%   following two fragments are identical, where we prefer the first
 539%   as it is more concise and less error-prone.
 540%
 541%   ==
 542%           html(table(border=1, \table_content))
 543%   ==
 544%   ==
 545%           html_begin(table(border=1)
 546%           table_content,
 547%           html_end(table)
 548%   ==
 549
 550html_begin(Env) -->
 551    { Env =.. [Name|Attributes]
 552    },
 553    html_begin(Name, Attributes).
 554
 555html_begin(Env, Attributes) -->
 556    pre_open(Env),
 557    [<],
 558    [Env],
 559    attributes(Env, Attributes),
 560    (   { layout(Env, _, empty),
 561          html_current_option(dialect(xhtml))
 562        }
 563    ->  ['/>']
 564    ;   [>]
 565    ),
 566    post_open(Env).
 567
 568html_end(Env)   -->                     % empty element or omited close
 569    { layout(Env, _, -),
 570      html_current_option(dialect(html))
 571    ; layout(Env, _, empty)
 572    },
 573    !,
 574    [].
 575html_end(Env)   -->
 576    pre_close(Env),
 577    ['</'],
 578    [Env],
 579    ['>'],
 580    post_close(Env).
 581
 582%!  xhtml_empty(+Env, +Attributes)// is det.
 583%
 584%   Emit element in xhtml mode with empty content.
 585
 586xhtml_empty(Env, Attributes) -->
 587    pre_open(Env),
 588    [<],
 589    [Env],
 590    attributes(Attributes),
 591    ['/>'].
 592
 593%!  xhtml_ns(+Id, +Value)//
 594%
 595%   Demand an xmlns:id=Value in the outer   html  tag. This uses the
 596%   html_post/2 mechanism to  post  to   the  =xmlns=  channel. Rdfa
 597%   (http://www.w3.org/2006/07/SWD/RDFa/syntax/), embedding RDF   in
 598%   (x)html provides a typical  usage  scenario   where  we  want to
 599%   publish the required namespaces in the header. We can define:
 600%
 601%   ==
 602%   rdf_ns(Id) -->
 603%           { rdf_global_id(Id:'', Value) },
 604%           xhtml_ns(Id, Value).
 605%   ==
 606%
 607%   After which we can use rdf_ns//1 as  a normal rule in html//1 to
 608%   publish namespaces from library(semweb/rdf_db).   Note that this
 609%   macro only has effect if  the  dialect   is  set  to =xhtml=. In
 610%   =html= mode it is silently ignored.
 611%
 612%   The required =xmlns= receiver  is   installed  by  html_begin//1
 613%   using the =html= tag and thus is   present  in any document that
 614%   opens the outer =html= environment through this library.
 615
 616xhtml_ns(Id, Value) -->
 617    { html_current_option(dialect(xhtml)) },
 618    !,
 619    html_post(xmlns, \attribute(xmlns:Id=Value)).
 620xhtml_ns(_, _) -->
 621    [].
 622
 623%!  html_root_attribute(+Name, +Value)//
 624%
 625%   Add an attribute to the  HTML  root   element  of  the page. For
 626%   example:
 627%
 628%     ==
 629%         html(div(...)),
 630%         html_root_attribute(lang, en),
 631%         ...
 632%     ==
 633
 634html_root_attribute(Name, Value) -->
 635    html_post(html_begin, \attribute(Name=Value)).
 636
 637%!  attributes(+Env, +Attributes)// is det.
 638%
 639%   Emit attributes for Env. Adds XHTML namespace declaration to the
 640%   html tag if not provided by the caller.
 641
 642attributes(html, L) -->
 643    !,
 644    (   { html_current_option(dialect(xhtml)) }
 645    ->  (   { option(xmlns(_), L) }
 646        ->  attributes(L)
 647        ;   { ns(xhtml, NS) },
 648            attributes([xmlns(NS)|L])
 649        ),
 650        html_receive(xmlns)
 651    ;   attributes(L),
 652        html_noreceive(xmlns)
 653    ),
 654    html_receive(html_begin).
 655attributes(_, L) -->
 656    attributes(L).
 657
 658attributes([]) -->
 659    !,
 660    [].
 661attributes([H|T]) -->
 662    !,
 663    attribute(H),
 664    attributes(T).
 665attributes(One) -->
 666    attribute(One).
 667
 668attribute(Name=Value) -->
 669    !,
 670    [' '], name(Name), [ '="' ],
 671    attribute_value(Value),
 672    ['"'].
 673attribute(NS:Term) -->
 674    !,
 675    { Term =.. [Name, Value]
 676    },
 677    !,
 678    attribute((NS:Name)=Value).
 679attribute(Term) -->
 680    { Term =.. [Name, Value]
 681    },
 682    !,
 683    attribute(Name=Value).
 684attribute(Atom) -->                     % Value-abbreviated attribute
 685    { atom(Atom)
 686    },
 687    [ ' ', Atom ].
 688
 689name(NS:Name) -->
 690    !,
 691    [NS, :, Name].
 692name(Name) -->
 693    [ Name ].
 694
 695%!  attribute_value(+Value) is det.
 696%
 697%   Print an attribute value. Value is either   atomic or one of the
 698%   following terms:
 699%
 700%     * A+B
 701%     Concatenation of A and B
 702%     * encode(V)
 703%     Emit URL-encoded version of V.  See www_form_encode/2.
 704%     * An option list
 705%     Emit ?Name1=encode(Value1)&Name2=encode(Value2) ...
 706%     * A term Format-Arguments
 707%     Use format/3 and emit the result as quoted value.
 708%
 709%   The hook html_write:expand_attribute_value//1 can  be defined to
 710%   provide additional `function like'   translations.  For example,
 711%   http_dispatch.pl  defines  location_by_id(ID)  to   refer  to  a
 712%   location on the current server  based   on  the  handler id. See
 713%   http_location_by_id/2.
 714
 715:- multifile
 716    expand_attribute_value//1.
 717
 718attribute_value(List) -->
 719    { is_list(List) },
 720    !,
 721    attribute_value_m(List).
 722attribute_value(Value) -->
 723    attribute_value_s(Value).
 724
 725% emit a single attribute value
 726
 727attribute_value_s(Var) -->
 728    { var(Var),
 729      !,
 730      instantiation_error(Var)
 731    }.
 732attribute_value_s(A+B) -->
 733    !,
 734    attribute_value(A),
 735    (   { is_list(B) }
 736    ->  (   { B == [] }
 737        ->  []
 738        ;   [?], search_parameters(B)
 739        )
 740    ;   attribute_value(B)
 741    ).
 742attribute_value_s(encode(Value)) -->
 743    !,
 744    { uri_encoded(query_value, Value, Encoded) },
 745    [ Encoded ].
 746attribute_value_s(Value) -->
 747    expand_attribute_value(Value),
 748    !.
 749attribute_value_s(Fmt-Args) -->
 750    !,
 751    { format(string(Value), Fmt, Args) },
 752    html_quoted_attribute(Value).
 753attribute_value_s(Value) -->
 754    html_quoted_attribute(Value).
 755
 756search_parameters([H|T]) -->
 757    search_parameter(H),
 758    (   {T == []}
 759    ->  []
 760    ;   ['&amp;'],
 761        search_parameters(T)
 762    ).
 763
 764search_parameter(Var) -->
 765    { var(Var),
 766      !,
 767      instantiation_error(Var)
 768    }.
 769search_parameter(Name=Value) -->
 770    { www_form_encode(Value, Encoded) },
 771    [Name, =, Encoded].
 772search_parameter(Term) -->
 773    { Term =.. [Name, Value],
 774      !,
 775      www_form_encode(Value, Encoded)
 776    },
 777    [Name, =, Encoded].
 778search_parameter(Term) -->
 779    { domain_error(search_parameter, Term)
 780    }.
 781
 782%!  attribute_value_m(+List)//
 783%
 784%   Used for multi-valued attributes, such as class-lists.  E.g.,
 785%
 786%     ==
 787%           body(class([c1, c2]), Body)
 788%     ==
 789%
 790%     Emits =|<body class="c1 c2"> ...|=
 791
 792attribute_value_m([]) -->
 793    [].
 794attribute_value_m([H|T]) -->
 795    attribute_value_s(H),
 796    (   { T == [] }
 797    ->  []
 798    ;   [' '],
 799        attribute_value_m(T)
 800    ).
 801
 802
 803                 /*******************************
 804                 *         QUOTING RULES        *
 805                 *******************************/
 806
 807%!  html_quoted(Text)// is det.
 808%
 809%   Quote  the  value  for  normal  (CDATA)  text.  Note  that  text
 810%   appearing in the document  structure   is  normally quoted using
 811%   these rules. I.e. the following emits  properly quoted bold text
 812%   regardless of the content of Text:
 813%
 814%   ==
 815%           html(b(Text))
 816%   ==
 817%
 818%   @tbd    Assumes UTF-8 encoding of the output.
 819
 820html_quoted(Text) -->
 821    { xml_quote_cdata(Text, Quoted, utf8) },
 822    [ Quoted ].
 823
 824%!  html_quoted_attribute(+Text)// is det.
 825%
 826%   Quote the value  according  to   the  rules  for  tag-attributes
 827%   included in double-quotes.  Note   that  -like  html_quoted//1-,
 828%   attributed   values   printed   through   html//1   are   quoted
 829%   atomatically.
 830%
 831%   @tbd    Assumes UTF-8 encoding of the output.
 832
 833html_quoted_attribute(Text) -->
 834    { xml_quote_attribute(Text, Quoted, utf8) },
 835    [ Quoted ].
 836
 837%!  cdata_element(?Element)
 838%
 839%   True when Element contains declared CDATA   and thus only =|</|=
 840%   needs to be escaped.
 841
 842cdata_element(script).
 843cdata_element(style).
 844
 845
 846                 /*******************************
 847                 *      REPOSITIONING HTML      *
 848                 *******************************/
 849
 850%!  html_post(+Id, :HTML)// is det.
 851%
 852%   Reposition HTML to  the  receiving   Id.  The  html_post//2 call
 853%   processes HTML using html//1. Embedded   \-commands are executed
 854%   by mailman/1 from  print_html/1   or  html_print_length/2. These
 855%   commands are called in the calling   context of the html_post//2
 856%   call.
 857%
 858%   A typical usage scenario is to  get   required  CSS links in the
 859%   document head in a reusable fashion. First, we define css//1 as:
 860%
 861%   ==
 862%   css(URL) -->
 863%           html_post(css,
 864%                     link([ type('text/css'),
 865%                            rel('stylesheet'),
 866%                            href(URL)
 867%                          ])).
 868%   ==
 869%
 870%   Next we insert the _unique_ CSS links, in the pagehead using the
 871%   following call to reply_html_page/2:
 872%
 873%   ==
 874%           reply_html_page([ title(...),
 875%                             \html_receive(css)
 876%                           ],
 877%                           ...)
 878%   ==
 879
 880html_post(Id, Content) -->
 881    { strip_module(Content, M, C) },
 882    [ mailbox(Id, post(M, C)) ].
 883
 884%!  html_receive(+Id)// is det.
 885%
 886%   Receive posted HTML tokens. Unique   sequences  of tokens posted
 887%   with  html_post//2  are  inserted   at    the   location   where
 888%   html_receive//1 appears.
 889%
 890%   @see    The local predicate sorted_html//1 handles the output of
 891%           html_receive//1.
 892%   @see    html_receive//2 allows for post-processing the posted
 893%           material.
 894
 895html_receive(Id) -->
 896    html_receive(Id, sorted_html).
 897
 898%!  html_receive(+Id, :Handler)// is det.
 899%
 900%   This extended version of html_receive//1   causes  Handler to be
 901%   called to process all messages posted to the channal at the time
 902%   output  is  generated.  Handler  is    called  as  below,  where
 903%   `PostedTerms` is a list of  Module:Term   created  from calls to
 904%   html_post//2. Module is the context module of html_post and Term
 905%   is the unmodified term. Members  in   `PostedTerms`  are  in the
 906%   order posted and may contain duplicates.
 907%
 908%     ==
 909%       phrase(Handler, PostedTerms, HtmlTerms, Rest)
 910%     ==
 911%
 912%   Typically, Handler collects the posted   terms,  creating a term
 913%   suitable for html//1 and finally calls html//1.
 914
 915html_receive(Id, Handler) -->
 916    { strip_module(Handler, M, P) },
 917    [ mailbox(Id, accept(M:P, _)) ].
 918
 919%!  html_noreceive(+Id)// is det.
 920%
 921%   As html_receive//1, but discard posted messages.
 922
 923html_noreceive(Id) -->
 924    [ mailbox(Id, ignore(_,_)) ].
 925
 926%!  mailman(+Tokens) is det.
 927%
 928%   Collect  posted  tokens  and  copy    them  into  the  receiving
 929%   mailboxes. Mailboxes may produce output for  each other, but not
 930%   cyclic. The current scheme to resolve   this is rather naive: It
 931%   simply permutates the mailbox resolution order  until it found a
 932%   working one. Before that, it puts   =head= and =script= boxes at
 933%   the end.
 934
 935mailman(Tokens) :-
 936    (   html_token(mailbox(_, accept(_, Accepted)), Tokens)
 937    ->  true
 938    ),
 939    var(Accepted),                 % not yet executed
 940    !,
 941    mailboxes(Tokens, Boxes),
 942    keysort(Boxes, Keyed),
 943    group_pairs_by_key(Keyed, PerKey),
 944    move_last(PerKey, script, PerKey1),
 945    move_last(PerKey1, head, PerKey2),
 946    (   permutation(PerKey2, PerKeyPerm),
 947        (   mail_ids(PerKeyPerm)
 948        ->  !
 949        ;   debug(html(mailman),
 950                  'Failed mail delivery order; retrying', []),
 951            fail
 952        )
 953    ->  true
 954    ;   print_message(error, html(cyclic_mailboxes))
 955    ).
 956mailman(_).
 957
 958move_last(Box0, Id, Box) :-
 959    selectchk(Id-List, Box0, Box1),
 960    !,
 961    append(Box1, [Id-List], Box).
 962move_last(Box, _, Box).
 963
 964%!  html_token(?Token, +Tokens) is nondet.
 965%
 966%   True if Token is a token in the  token set. This is like member,
 967%   but the toplevel list may contain cdata(Elem, Tokens).
 968
 969html_token(Token, [H|T]) :-
 970    html_token_(T, H, Token).
 971
 972html_token_(_, Token, Token) :- !.
 973html_token_(_, cdata(_,Tokens), Token) :-
 974    html_token(Token, Tokens).
 975html_token_([H|T], _, Token) :-
 976    html_token_(T, H, Token).
 977
 978%!  mailboxes(+Tokens, -MailBoxes) is det.
 979%
 980%   Get all mailboxes from the token set.
 981
 982mailboxes(Tokens, MailBoxes) :-
 983    mailboxes(Tokens, MailBoxes, []).
 984
 985mailboxes([], List, List).
 986mailboxes([mailbox(Id, Value)|T0], [Id-Value|T], Tail) :-
 987    !,
 988    mailboxes(T0, T, Tail).
 989mailboxes([cdata(_Type, Tokens)|T0], Boxes, Tail) :-
 990    !,
 991    mailboxes(Tokens, Boxes, Tail0),
 992    mailboxes(T0, Tail0, Tail).
 993mailboxes([_|T0], T, Tail) :-
 994    mailboxes(T0, T, Tail).
 995
 996mail_ids([]).
 997mail_ids([H|T0]) :-
 998    mail_id(H, NewPosts),
 999    add_new_posts(NewPosts, T0, T),
1000    mail_ids(T).
1001
1002mail_id(Id-List, NewPosts) :-
1003    mail_handlers(List, Boxes, Content),
1004    (   Boxes = [accept(MH:Handler, In)]
1005    ->  extend_args(Handler, Content, Goal),
1006        phrase(MH:Goal, In),
1007        mailboxes(In, NewBoxes),
1008        keysort(NewBoxes, Keyed),
1009        group_pairs_by_key(Keyed, NewPosts)
1010    ;   Boxes = [ignore(_, _)|_]
1011    ->  NewPosts = []
1012    ;   Boxes = [accept(_,_),accept(_,_)|_]
1013    ->  print_message(error, html(multiple_receivers(Id))),
1014        NewPosts = []
1015    ;   print_message(error, html(no_receiver(Id))),
1016        NewPosts = []
1017    ).
1018
1019add_new_posts([], T, T).
1020add_new_posts([Id-Posts|NewT], T0, T) :-
1021    (   select(Id-List0, T0, Id-List, T1)
1022    ->  append(List0, Posts, List)
1023    ;   debug(html(mailman), 'Stuck with new posts on ~q', [Id]),
1024        fail
1025    ),
1026    add_new_posts(NewT, T1, T).
1027
1028
1029%!  mail_handlers(+Boxes, -Handlers, -Posters) is det.
1030%
1031%   Collect all post(Module,HTML) into Posters  and the remainder in
1032%   Handlers.  Handlers  consists  of  accept(Handler,  Tokens)  and
1033%   ignore(_,_).
1034
1035mail_handlers([], [], []).
1036mail_handlers([post(Module,HTML)|T0], H, [Module:HTML|T]) :-
1037    !,
1038    mail_handlers(T0, H, T).
1039mail_handlers([H|T0], [H|T], C) :-
1040    mail_handlers(T0, T, C).
1041
1042extend_args(Term, Extra, NewTerm) :-
1043    Term =.. [Name|Args],
1044    append(Args, [Extra], NewArgs),
1045    NewTerm =.. [Name|NewArgs].
1046
1047%!  sorted_html(+Content:list)// is det.
1048%
1049%   Default  handlers  for  html_receive//1.  It  sorts  the  posted
1050%   objects to create a unique list.
1051%
1052%   @bug    Elements can differ just on the module.  Ideally we
1053%           should phrase all members, sort the list of list of
1054%           tokens and emit the result.  Can we do better?
1055
1056sorted_html(List) -->
1057    { sort(List, Unique) },
1058    html(Unique).
1059
1060%!  head_html(+Content:list)// is det.
1061%
1062%   Handler for html_receive(head). Unlike  sorted_html//1, it calls
1063%   a user hook  html_write:html_head_expansion/2   to  process  the
1064%   collected head material into a term suitable for html//1.
1065%
1066%   @tbd  This  has  been  added   to  facilitate  html_head.pl,  an
1067%   experimental  library  for  dealing  with   css  and  javascript
1068%   resources. It feels a bit like a hack, but for now I do not know
1069%   a better solution.
1070
1071head_html(List) -->
1072    { list_to_set(List, Unique),
1073      html_expand_head(Unique, NewList)
1074    },
1075    html(NewList).
1076
1077:- multifile
1078    html_head_expansion/2.
1079
1080html_expand_head(List0, List) :-
1081    html_head_expansion(List0, List1),
1082    List0 \== List1,
1083    !,
1084    html_expand_head(List1, List).
1085html_expand_head(List, List).
1086
1087
1088                 /*******************************
1089                 *             LAYOUT           *
1090                 *******************************/
1091
1092pre_open(Env) -->
1093    { layout(Env, N-_, _)
1094    },
1095    !,
1096    [ nl(N) ].
1097pre_open(_) --> [].
1098
1099post_open(Env) -->
1100    { layout(Env, _-N, _)
1101    },
1102    !,
1103    [ nl(N) ].
1104post_open(_) -->
1105    [].
1106
1107pre_close(head) -->
1108    !,
1109    html_receive(head, head_html),
1110    { layout(head, _, N-_) },
1111    [ nl(N) ].
1112pre_close(Env) -->
1113    { layout(Env, _, N-_)
1114    },
1115    !,
1116    [ nl(N) ].
1117pre_close(_) -->
1118    [].
1119
1120post_close(Env) -->
1121    { layout(Env, _, _-N)
1122    },
1123    !,
1124    [ nl(N) ].
1125post_close(_) -->
1126    [].
1127
1128%!  layout(+Tag, -Open, -Close) is det.
1129%
1130%   Define required newlines before and after   tags.  This table is
1131%   rather incomplete. New rules can  be   added  to  this multifile
1132%   predicate.
1133%
1134%   @param Tag      Name of the tag
1135%   @param Open     Tuple M-N, where M is the number of lines before
1136%                   the tag and N after.
1137%   @param Close    Either as Open, or the atom - (minus) to omit the
1138%                   close-tag or =empty= to indicate the element has
1139%                   no content model.
1140%
1141%   @tbd    Complete table
1142
1143:- multifile
1144    layout/3.
1145
1146layout(table,      2-1, 1-2).
1147layout(blockquote, 2-1, 1-2).
1148layout(pre,        2-1, 0-2).
1149layout(textarea,   1-1, 0-1).
1150layout(center,     2-1, 1-2).
1151layout(dl,         2-1, 1-2).
1152layout(ul,         1-1, 1-1).
1153layout(ol,         2-1, 1-2).
1154layout(form,       2-1, 1-2).
1155layout(frameset,   2-1, 1-2).
1156layout(address,    2-1, 1-2).
1157
1158layout(head,       1-1, 1-1).
1159layout(body,       1-1, 1-1).
1160layout(script,     1-1, 1-1).
1161layout(style,      1-1, 1-1).
1162layout(select,     1-1, 1-1).
1163layout(map,        1-1, 1-1).
1164layout(html,       1-1, 1-1).
1165layout(caption,    1-1, 1-1).
1166layout(applet,     1-1, 1-1).
1167
1168layout(tr,         1-0, 0-1).
1169layout(option,     1-0, 0-1).
1170layout(li,         1-0, 0-1).
1171layout(dt,         1-0, -).
1172layout(dd,         0-0, -).
1173layout(title,      1-0, 0-1).
1174
1175layout(h1,         2-0, 0-2).
1176layout(h2,         2-0, 0-2).
1177layout(h3,         2-0, 0-2).
1178layout(h4,         2-0, 0-2).
1179
1180layout(iframe,     1-1, 1-1).
1181
1182layout(hr,         1-1, empty).         % empty elements
1183layout(br,         0-1, empty).
1184layout(img,        0-0, empty).
1185layout(meta,       1-1, empty).
1186layout(base,       1-1, empty).
1187layout(link,       1-1, empty).
1188layout(input,      0-0, empty).
1189layout(frame,      1-1, empty).
1190layout(col,        0-0, empty).
1191layout(area,       1-0, empty).
1192layout(input,      1-0, empty).
1193layout(param,      1-0, empty).
1194
1195layout(p,          2-1, -).             % omited close
1196layout(td,         0-0, 0-0).
1197
1198layout(div,        1-0, 0-1).
1199
1200                 /*******************************
1201                 *           PRINTING           *
1202                 *******************************/
1203
1204%!  print_html(+List) is det.
1205%!  print_html(+Out:stream, +List) is det.
1206%
1207%   Print list of atoms and layout instructions.  Currently used layout
1208%   instructions:
1209%
1210%           * nl(N)
1211%           Use at minimum N newlines here.
1212%
1213%           * mailbox(Id, Box)
1214%           Repositioned tokens (see html_post//2 and
1215%           html_receive//2)
1216
1217print_html(List) :-
1218    current_output(Out),
1219    mailman(List),
1220    write_html(List, Out).
1221print_html(Out, List) :-
1222    (   html_current_option(dialect(xhtml))
1223    ->  stream_property(Out, encoding(Enc)),
1224        (   Enc == utf8
1225        ->  true
1226        ;   print_message(warning, html(wrong_encoding(Out, Enc)))
1227        ),
1228        xml_header(Hdr),
1229        write(Out, Hdr), nl(Out)
1230    ;   true
1231    ),
1232    mailman(List),
1233    write_html(List, Out),
1234    flush_output(Out).
1235
1236write_html([], _).
1237write_html([nl(N)|T], Out) :-
1238    !,
1239    join_nl(T, N, Lines, T2),
1240    write_nl(Lines, Out),
1241    write_html(T2, Out).
1242write_html([mailbox(_, Box)|T], Out) :-
1243    !,
1244    (   Box = accept(_, Accepted)
1245    ->  write_html(Accepted, Out)
1246    ;   true
1247    ),
1248    write_html(T, Out).
1249write_html([cdata(Env, Tokens)|T], Out) :-
1250    !,
1251    with_output_to(string(CDATA), write_html(Tokens, current_output)),
1252    valid_cdata(Env, CDATA),
1253    write(Out, CDATA),
1254    write_html(T, Out).
1255write_html([H|T], Out) :-
1256    write(Out, H),
1257    write_html(T, Out).
1258
1259join_nl([nl(N0)|T0], N1, N, T) :-
1260    !,
1261    N2 is max(N0, N1),
1262    join_nl(T0, N2, N, T).
1263join_nl(L, N, N, L).
1264
1265write_nl(0, _) :- !.
1266write_nl(N, Out) :-
1267    nl(Out),
1268    N1 is N - 1,
1269    write_nl(N1, Out).
1270
1271%!  valid_cdata(+Env, +String) is det.
1272%
1273%   True when String is valid content for   a  CDATA element such as
1274%   =|<script>|=. This implies  it   cannot  contain  =|</script/|=.
1275%   There is no escape for this and  the script generator must use a
1276%   work-around using features of the  script language. For example,
1277%   when  using  JavaScript,  "</script>"   can    be   written   as
1278%   "<\/script>".
1279%
1280%   @see write_json/2, js_arg//1.
1281%   @error domain_error(cdata, String)
1282
1283valid_cdata(Env, String) :-
1284    atomics_to_string(['</', Env, '>'], End),
1285    sub_atom_icasechk(String, _, End),
1286    !,
1287    domain_error(cdata, String).
1288valid_cdata(_, _).
1289
1290%!  html_print_length(+List, -Len) is det.
1291%
1292%   Determine the content length of  a   token  list  produced using
1293%   html//1. Here is an example on  how   this  is used to output an
1294%   HTML compatible to HTTP:
1295%
1296%   ==
1297%           phrase(html(DOM), Tokens),
1298%           html_print_length(Tokens, Len),
1299%           format('Content-type: text/html; charset=UTF-8~n'),
1300%           format('Content-length: ~d~n~n', [Len]),
1301%           print_html(Tokens)
1302%   ==
1303
1304html_print_length(List, Len) :-
1305    mailman(List),
1306    (   html_current_option(dialect(xhtml))
1307    ->  xml_header(Hdr),
1308        atom_length(Hdr, L0),
1309        L1 is L0+1                  % one for newline
1310    ;   L1 = 0
1311    ),
1312    html_print_length(List, L1, Len).
1313
1314html_print_length([], L, L).
1315html_print_length([nl(N)|T], L0, L) :-
1316    !,
1317    join_nl(T, N, Lines, T1),
1318    L1 is L0 + Lines,               % assume only \n!
1319    html_print_length(T1, L1, L).
1320html_print_length([mailbox(_, Box)|T], L0, L) :-
1321    !,
1322    (   Box = accept(_, Accepted)
1323    ->  html_print_length(Accepted, L0, L1)
1324    ;   L1 = L0
1325    ),
1326    html_print_length(T, L1, L).
1327html_print_length([cdata(_, CDATA)|T], L0, L) :-
1328    !,
1329    html_print_length(CDATA, L0, L1),
1330    html_print_length(T, L1, L).
1331html_print_length([H|T], L0, L) :-
1332    atom_length(H, Hlen),
1333    L1 is L0+Hlen,
1334    html_print_length(T, L1, L).
1335
1336
1337%!  reply_html_page(:Head, :Body) is det.
1338%!  reply_html_page(+Style, :Head, :Body) is det.
1339%
1340%   Provide the complete reply as required  by http_wrapper.pl for a
1341%   page constructed from Head and   Body. The HTTP =|Content-type|=
1342%   is provided by html_current_option/1.
1343
1344reply_html_page(Head, Body) :-
1345    reply_html_page(default, Head, Body).
1346reply_html_page(Style, Head, Body) :-
1347    html_current_option(content_type(Type)),
1348    phrase(page(Style, Head, Body), HTML),
1349    format('Content-type: ~w~n~n', [Type]),
1350    print_html(HTML).
1351
1352
1353                 /*******************************
1354                 *     META-PREDICATE SUPPORT   *
1355                 *******************************/
1356
1357%!  html_meta(+Heads) is det.
1358%
1359%   This directive can be used  to   declare  that an HTML rendering
1360%   rule takes HTML content as  argument.   It  has  two effects. It
1361%   emits  the  appropriate  meta_predicate/1    and  instructs  the
1362%   built-in editor (PceEmacs) to provide   proper colouring for the
1363%   arguments.  The  arguments  in  Head  are    the   same  as  for
1364%   meta_predicate or can be constant =html=.  For example:
1365%
1366%     ==
1367%     :- html_meta
1368%           page(html,html,?,?).
1369%     ==
1370
1371html_meta(Spec) :-
1372    throw(error(context_error(nodirective, html_meta(Spec)), _)).
1373
1374html_meta_decls(Var, _, _) :-
1375    var(Var),
1376    !,
1377    instantiation_error(Var).
1378html_meta_decls((A,B), (MA,MB), [MH|T]) :-
1379    !,
1380    html_meta_decl(A, MA, MH),
1381    html_meta_decls(B, MB, T).
1382html_meta_decls(A, MA, [MH]) :-
1383    html_meta_decl(A, MA, MH).
1384
1385html_meta_decl(Head, MetaHead,
1386               html_write:html_meta_head(GenHead, Module, Head)) :-
1387    functor(Head, Name, Arity),
1388    functor(GenHead, Name, Arity),
1389    prolog_load_context(module, Module),
1390    Head =.. [Name|HArgs],
1391    maplist(html_meta_decl, HArgs, MArgs),
1392    MetaHead =.. [Name|MArgs].
1393
1394html_meta_decl(html, :) :- !.
1395html_meta_decl(Meta, Meta).
1396
1397system:term_expansion((:- html_meta(Heads)),
1398                      [ (:- meta_predicate(Meta))
1399                      | MetaHeads
1400                      ]) :-
1401    html_meta_decls(Heads, Meta, MetaHeads).
1402
1403:- multifile
1404    html_meta_head/3.
1405
1406html_meta_colours(Head, Goal, built_in-Colours) :-
1407    Head =.. [_|MArgs],
1408    Goal =.. [_|Args],
1409    maplist(meta_colours, MArgs, Args, Colours).
1410
1411meta_colours(html, HTML, Colours) :-
1412    !,
1413    html_colours(HTML, Colours).
1414meta_colours(I, _, Colours) :-
1415    integer(I), I>=0,
1416    !,
1417    Colours = meta(I).
1418meta_colours(_, _, classify).
1419
1420html_meta_called(Head, Goal, Called) :-
1421    Head =.. [_|MArgs],
1422    Goal =.. [_|Args],
1423    meta_called(MArgs, Args, Called, []).
1424
1425meta_called([], [], Called, Called).
1426meta_called([html|MT], [A|AT], Called, Tail) :-
1427    !,
1428    phrase(called_by(A), Called, Tail1),
1429    meta_called(MT, AT, Tail1, Tail).
1430meta_called([0|MT], [A|AT], [A|CT0], CT) :-
1431    !,
1432    meta_called(MT, AT, CT0, CT).
1433meta_called([I|MT], [A|AT], [A+I|CT0], CT) :-
1434    integer(I), I>0,
1435    !,
1436    meta_called(MT, AT, CT0, CT).
1437meta_called([_|MT], [_|AT], Called, Tail) :-
1438    !,
1439    meta_called(MT, AT, Called, Tail).
1440
1441
1442:- html_meta
1443    html(html,?,?),
1444    page(html,?,?),
1445    page(html,html,?,?),
1446    page(+,html,html,?,?),
1447    pagehead(+,html,?,?),
1448    pagebody(+,html,?,?),
1449    reply_html_page(html,html),
1450    reply_html_page(+,html,html),
1451    html_post(+,html,?,?).
1452
1453
1454                 /*******************************
1455                 *      PCE EMACS SUPPORT       *
1456                 *******************************/
1457
1458:- multifile
1459    prolog_colour:goal_colours/2,
1460    prolog_colour:style/2,
1461    prolog_colour:message//1,
1462    prolog:called_by/2.
1463
1464prolog_colour:goal_colours(Goal, Colours) :-
1465    html_meta_head(Goal, _Module, Head),
1466    html_meta_colours(Head, Goal, Colours).
1467prolog_colour:goal_colours(html_meta(_),
1468                           built_in-[meta_declarations([html])]).
1469
1470                                        % TBD: Check with do_expand!
1471html_colours(Var, classify) :-
1472    var(Var),
1473    !.
1474html_colours(\List, built_in-[built_in-Colours]) :-
1475    is_list(List),
1476    !,
1477    list_colours(List, Colours).
1478html_colours(\_, built_in-[dcg]) :- !.
1479html_colours(_:Term, built_in-[classify,Colours]) :-
1480    !,
1481    html_colours(Term, Colours).
1482html_colours(&(Entity), functor-[entity(Entity)]) :- !.
1483html_colours(List, list-ListColours) :-
1484    List = [_|_],
1485    !,
1486    list_colours(List, ListColours).
1487html_colours(Term, TermColours) :-
1488    compound(Term),
1489    compound_name_arguments(Term, Name, Args),
1490    Name \== '.',
1491    !,
1492    (   Args = [One]
1493    ->  TermColours = html(Name)-ArgColours,
1494        (   layout(Name, _, empty)
1495        ->  attr_colours(One, ArgColours)
1496        ;   html_colours(One, Colours),
1497            ArgColours = [Colours]
1498        )
1499    ;   Args = [AList,Content]
1500    ->  TermColours = html(Name)-[AColours, Colours],
1501        attr_colours(AList, AColours),
1502        html_colours(Content, Colours)
1503    ;   TermColours = error
1504    ).
1505html_colours(_, classify).
1506
1507list_colours(Var, classify) :-
1508    var(Var),
1509    !.
1510list_colours([], []).
1511list_colours([H0|T0], [H|T]) :-
1512    !,
1513    html_colours(H0, H),
1514    list_colours(T0, T).
1515list_colours(Last, Colours) :-          % improper list
1516    html_colours(Last, Colours).
1517
1518attr_colours(Var, classify) :-
1519    var(Var),
1520    !.
1521attr_colours([], classify) :- !.
1522attr_colours(Term, list-Elements) :-
1523    Term = [_|_],
1524    !,
1525    attr_list_colours(Term, Elements).
1526attr_colours(Name=Value, built_in-[html_attribute(Name), VColour]) :-
1527    !,
1528    attr_value_colour(Value, VColour).
1529attr_colours(NS:Term, built_in-[ html_xmlns(NS),
1530                                 html_attribute(Name)-[classify]
1531                               ]) :-
1532    compound(Term),
1533    compound_name_arity(Term, Name, 1).
1534attr_colours(Term, html_attribute(Name)-[VColour]) :-
1535    compound(Term),
1536    compound_name_arity(Term, Name, 1),
1537    !,
1538    Term =.. [Name,Value],
1539    attr_value_colour(Value, VColour).
1540attr_colours(Name, html_attribute(Name)) :-
1541    atom(Name),
1542    !.
1543attr_colours(Term, classify) :-
1544    compound(Term),
1545    compound_name_arity(Term, '.', 2),
1546    !.
1547attr_colours(_, error).
1548
1549attr_list_colours(Var, classify) :-
1550    var(Var),
1551    !.
1552attr_list_colours([], []).
1553attr_list_colours([H0|T0], [H|T]) :-
1554    attr_colours(H0, H),
1555    attr_list_colours(T0, T).
1556
1557attr_value_colour(Var, classify) :-
1558    var(Var).
1559attr_value_colour(location_by_id(ID), sgml_attr_function-[Colour]) :-
1560    !,
1561    location_id(ID, Colour).
1562attr_value_colour(A+B, sgml_attr_function-[CA,CB]) :-
1563    !,
1564    attr_value_colour(A, CA),
1565    attr_value_colour(B, CB).
1566attr_value_colour(encode(_), sgml_attr_function-[classify]) :- !.
1567attr_value_colour(Atom, classify) :-
1568    atomic(Atom),
1569    !.
1570attr_value_colour([_|_], classify) :- !.
1571attr_value_colour(_Fmt-_Args, classify) :- !.
1572attr_value_colour(Term, classify) :-
1573    compound(Term),
1574    compound_name_arity(Term, '.', 2),
1575    !.
1576attr_value_colour(_, error).
1577
1578location_id(ID, classify) :-
1579    var(ID),
1580    !.
1581location_id(ID, Class) :-
1582    (   catch(http_dispatch:http_location_by_id(ID, Location), _, fail)
1583    ->  Class = http_location_for_id(Location)
1584    ;   Class = http_no_location_for_id(ID)
1585    ).
1586location_id(_, classify).
1587
1588
1589:- op(990, xfx, :=).                    % allow compiling without XPCE
1590:- op(200, fy, @).
1591
1592prolog_colour:style(html(_),                    [colour(magenta4), bold(true)]).
1593prolog_colour:style(entity(_),                  [colour(magenta4)]).
1594prolog_colour:style(html_attribute(_),          [colour(magenta4)]).
1595prolog_colour:style(html_xmlns(_),              [colour(magenta4)]).
1596prolog_colour:style(sgml_attr_function,         [colour(blue)]).
1597prolog_colour:style(http_location_for_id(_),    [bold(true)]).
1598prolog_colour:style(http_no_location_for_id(_), [colour(red), bold(true)]).
1599
1600
1601prolog_colour:message(html(Element)) -->
1602    [ '~w: SGML element'-[Element] ].
1603prolog_colour:message(entity(Entity)) -->
1604    [ '~w: SGML entity'-[Entity] ].
1605prolog_colour:message(html_attribute(Attr)) -->
1606    [ '~w: SGML attribute'-[Attr] ].
1607prolog_colour:message(sgml_attr_function) -->
1608    [ 'SGML Attribute function'-[] ].
1609prolog_colour:message(http_location_for_id(Location)) -->
1610    [ 'ID resolves to ~w'-[Location] ].
1611prolog_colour:message(http_no_location_for_id(ID)) -->
1612    [ '~w: no such ID'-[ID] ].
1613
1614
1615%       prolog:called_by(+Goal, -Called)
1616%
1617%       Hook into library(pce_prolog_xref).  Called is a list of callable
1618%       or callable+N to indicate (DCG) arglist extension.
1619
1620
1621prolog:called_by(Goal, Called) :-
1622    html_meta_head(Goal, _Module, Head),
1623    html_meta_called(Head, Goal, Called).
1624
1625called_by(Term) -->
1626    called_by(Term, _).
1627
1628called_by(Var, _) -->
1629    { var(Var) },
1630    !,
1631    [].
1632called_by(\G, M) -->
1633    !,
1634    (   { is_list(G) }
1635    ->  called_by(G, M)
1636    ;   {atom(M)}
1637    ->  [(M:G)+2]
1638    ;   [G+2]
1639    ).
1640called_by([], _) -->
1641    !,
1642    [].
1643called_by([H|T], M) -->
1644    !,
1645    called_by(H, M),
1646    called_by(T, M).
1647called_by(M:Term, _) -->
1648    !,
1649    (   {atom(M)}
1650    ->  called_by(Term, M)
1651    ;   []
1652    ).
1653called_by(Term, M) -->
1654    { compound(Term),
1655      !,
1656      Term =.. [_|Args]
1657    },
1658    called_by(Args, M).
1659called_by(_, _) -->
1660    [].
1661
1662:- multifile
1663    prolog:hook/1.
1664
1665prolog:hook(body(_,_,_)).
1666prolog:hook(body(_,_,_,_)).
1667prolog:hook(head(_,_,_)).
1668prolog:hook(head(_,_,_,_)).
1669
1670
1671                 /*******************************
1672                 *            MESSAGES          *
1673                 *******************************/
1674
1675:- multifile
1676    prolog:message/3.
1677
1678prolog:message(html(expand_failed(What))) -->
1679    [ 'Failed to translate to HTML: ~p'-[What] ].
1680prolog:message(html(wrong_encoding(Stream, Enc))) -->
1681    [ 'XHTML demands UTF-8 encoding; encoding of ~p is ~w'-[Stream, Enc] ].
1682prolog:message(html(multiple_receivers(Id))) -->
1683    [ 'html_post//2: multiple receivers for: ~p'-[Id] ].
1684prolog:message(html(no_receiver(Id))) -->
1685    [ 'html_post//2: no receivers for: ~p'-[Id] ].