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