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] ]