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