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(hr,         1-1, empty).         % empty elements
 1191layout(br,         0-1, empty).
 1192layout(img,        0-0, empty).
 1193layout(meta,       1-1, empty).
 1194layout(base,       1-1, empty).
 1195layout(link,       1-1, empty).
 1196layout(input,      0-0, empty).
 1197layout(frame,      1-1, empty).
 1198layout(col,        0-0, empty).
 1199layout(area,       1-0, empty).
 1200layout(input,      1-0, empty).
 1201layout(param,      1-0, empty).
 1202
 1203layout(p,          2-1, -).             % omited close
 1204layout(td,         0-0, 0-0).
 1205
 1206layout(div,        1-0, 0-1).
 1207
 1208                 /*******************************
 1209                 *           PRINTING           *
 1210                 *******************************/
 1211
 1212%!  print_html(+List) is det.
 1213%!  print_html(+Out:stream, +List) is det.
 1214%
 1215%   Print list of atoms and layout instructions.  Currently used layout
 1216%   instructions:
 1217%
 1218%           * nl(N)
 1219%           Use at minimum N newlines here.
 1220%
 1221%           * mailbox(Id, Box)
 1222%           Repositioned tokens (see html_post//2 and
 1223%           html_receive//2)
 1224
 1225print_html(List) :-
 1226    current_output(Out),
 1227    mailman(List),
 1228    write_html(List, Out).
 1229print_html(Out, List) :-
 1230    (   html_current_option(dialect(xhtml))
 1231    ->  stream_property(Out, encoding(Enc)),
 1232        (   Enc == utf8
 1233        ->  true
 1234        ;   print_message(warning, html(wrong_encoding(Out, Enc)))
 1235        ),
 1236        xml_header(Hdr),
 1237        write(Out, Hdr), nl(Out)
 1238    ;   true
 1239    ),
 1240    mailman(List),
 1241    write_html(List, Out),
 1242    flush_output(Out).
 1243
 1244write_html([], _).
 1245write_html([nl(N)|T], Out) :-
 1246    !,
 1247    join_nl(T, N, Lines, T2),
 1248    write_nl(Lines, Out),
 1249    write_html(T2, Out).
 1250write_html([mailbox(_, Box)|T], Out) :-
 1251    !,
 1252    (   Box = accept(_, Accepted)
 1253    ->  write_html(Accepted, Out)
 1254    ;   true
 1255    ),
 1256    write_html(T, Out).
 1257write_html([cdata(Env, Tokens)|T], Out) :-
 1258    !,
 1259    with_output_to(string(CDATA), write_html(Tokens, current_output)),
 1260    valid_cdata(Env, CDATA),
 1261    write(Out, CDATA),
 1262    write_html(T, Out).
 1263write_html([H|T], Out) :-
 1264    write(Out, H),
 1265    write_html(T, Out).
 1266
 1267join_nl([nl(N0)|T0], N1, N, T) :-
 1268    !,
 1269    N2 is max(N0, N1),
 1270    join_nl(T0, N2, N, T).
 1271join_nl(L, N, N, L).
 1272
 1273write_nl(0, _) :- !.
 1274write_nl(N, Out) :-
 1275    nl(Out),
 1276    N1 is N - 1,
 1277    write_nl(N1, Out).
 1278
 1279%!  valid_cdata(+Env, +String) is det.
 1280%
 1281%   True when String is valid content for   a  CDATA element such as
 1282%   =|<script>|=. This implies  it   cannot  contain  =|</script/|=.
 1283%   There is no escape for this and  the script generator must use a
 1284%   work-around using features of the  script language. For example,
 1285%   when  using  JavaScript,  "</script>"   can    be   written   as
 1286%   "<\/script>".
 1287%
 1288%   @see write_json/2, js_arg//1.
 1289%   @error domain_error(cdata, String)
 1290
 1291valid_cdata(Env, String) :-
 1292    atomics_to_string(['</', Env, '>'], End),
 1293    sub_atom_icasechk(String, _, End),
 1294    !,
 1295    domain_error(cdata, String).
 1296valid_cdata(_, _).
 1297
 1298%!  html_print_length(+List, -Len) is det.
 1299%
 1300%   Determine the content length of  a   token  list  produced using
 1301%   html//1. Here is an example on  how   this  is used to output an
 1302%   HTML compatible to HTTP:
 1303%
 1304%   ==
 1305%           phrase(html(DOM), Tokens),
 1306%           html_print_length(Tokens, Len),
 1307%           format('Content-type: text/html; charset=UTF-8~n'),
 1308%           format('Content-length: ~d~n~n', [Len]),
 1309%           print_html(Tokens)
 1310%   ==
 1311
 1312html_print_length(List, Len) :-
 1313    mailman(List),
 1314    (   html_current_option(dialect(xhtml))
 1315    ->  xml_header(Hdr),
 1316        atom_length(Hdr, L0),
 1317        L1 is L0+1                  % one for newline
 1318    ;   L1 = 0
 1319    ),
 1320    html_print_length(List, L1, Len).
 1321
 1322html_print_length([], L, L).
 1323html_print_length([nl(N)|T], L0, L) :-
 1324    !,
 1325    join_nl(T, N, Lines, T1),
 1326    L1 is L0 + Lines,               % assume only \n!
 1327    html_print_length(T1, L1, L).
 1328html_print_length([mailbox(_, Box)|T], L0, L) :-
 1329    !,
 1330    (   Box = accept(_, Accepted)
 1331    ->  html_print_length(Accepted, L0, L1)
 1332    ;   L1 = L0
 1333    ),
 1334    html_print_length(T, L1, L).
 1335html_print_length([cdata(_, CDATA)|T], L0, L) :-
 1336    !,
 1337    html_print_length(CDATA, L0, L1),
 1338    html_print_length(T, L1, L).
 1339html_print_length([H|T], L0, L) :-
 1340    atom_length(H, Hlen),
 1341    L1 is L0+Hlen,
 1342    html_print_length(T, L1, L).
 1343
 1344
 1345%!  reply_html_page(:Head, :Body) is det.
 1346%!  reply_html_page(+Style, :Head, :Body) is det.
 1347%
 1348%   Provide the complete reply as required  by http_wrapper.pl for a
 1349%   page constructed from Head and   Body. The HTTP =|Content-type|=
 1350%   is provided by html_current_option/1.
 1351
 1352reply_html_page(Head, Body) :-
 1353    reply_html_page(default, Head, Body).
 1354reply_html_page(Style, Head, Body) :-
 1355    html_current_option(content_type(Type)),
 1356    phrase(page(Style, Head, Body), HTML),
 1357    forall(html_header_hook(Style), true),
 1358    format('Content-type: ~w~n~n', [Type]),
 1359    print_html(HTML).
 1360
 1361
 1362%!  html_header_hook(+Style) is nondet.
 1363%
 1364%   This multifile hook  is  called   just  before  the ``Content-type``
 1365%   header  is  emitted.  It  allows  for  emitting  additional  headers
 1366%   depending on the first argument of reply_html_page/3.
 1367
 1368
 1369
 1370                 /*******************************
 1371                 *     META-PREDICATE SUPPORT   *
 1372                 *******************************/
 1373
 1374%!  html_meta(+Heads) is det.
 1375%
 1376%   This directive can be used  to   declare  that an HTML rendering
 1377%   rule takes HTML content as  argument.   It  has  two effects. It
 1378%   emits  the  appropriate  meta_predicate/1    and  instructs  the
 1379%   built-in editor (PceEmacs) to provide   proper colouring for the
 1380%   arguments.  The  arguments  in  Head  are    the   same  as  for
 1381%   meta_predicate or can be constant =html=.  For example:
 1382%
 1383%     ==
 1384%     :- html_meta
 1385%           page(html,html,?,?).
 1386%     ==
 1387
 1388html_meta(Spec) :-
 1389    throw(error(context_error(nodirective, html_meta(Spec)), _)).
 1390
 1391html_meta_decls(Var, _, _) :-
 1392    var(Var),
 1393    !,
 1394    instantiation_error(Var).
 1395html_meta_decls((A,B), (MA,MB), [MH|T]) :-
 1396    !,
 1397    html_meta_decl(A, MA, MH),
 1398    html_meta_decls(B, MB, T).
 1399html_meta_decls(A, MA, [MH]) :-
 1400    html_meta_decl(A, MA, MH).
 1401
 1402html_meta_decl(Head, MetaHead,
 1403               html_write:html_meta_head(GenHead, Module, Head)) :-
 1404    functor(Head, Name, Arity),
 1405    functor(GenHead, Name, Arity),
 1406    prolog_load_context(module, Module),
 1407    Head =.. [Name|HArgs],
 1408    maplist(html_meta_decl, HArgs, MArgs),
 1409    MetaHead =.. [Name|MArgs].
 1410
 1411html_meta_decl(html, :) :- !.
 1412html_meta_decl(Meta, Meta).
 1413
 1414system:term_expansion((:- html_meta(Heads)),
 1415                      [ (:- meta_predicate(Meta))
 1416                      | MetaHeads
 1417                      ]) :-
 1418    html_meta_decls(Heads, Meta, MetaHeads).
 1419
 1420:- multifile
 1421    html_meta_head/3. 1422
 1423html_meta_colours(Head, Goal, built_in-Colours) :-
 1424    Head =.. [_|MArgs],
 1425    Goal =.. [_|Args],
 1426    maplist(meta_colours, MArgs, Args, Colours).
 1427
 1428meta_colours(html, HTML, Colours) :-
 1429    !,
 1430    html_colours(HTML, Colours).
 1431meta_colours(I, _, Colours) :-
 1432    integer(I), I>=0,
 1433    !,
 1434    Colours = meta(I).
 1435meta_colours(_, _, classify).
 1436
 1437html_meta_called(Head, Goal, Called) :-
 1438    Head =.. [_|MArgs],
 1439    Goal =.. [_|Args],
 1440    meta_called(MArgs, Args, Called, []).
 1441
 1442meta_called([], [], Called, Called).
 1443meta_called([html|MT], [A|AT], Called, Tail) :-
 1444    !,
 1445    phrase(called_by(A), Called, Tail1),
 1446    meta_called(MT, AT, Tail1, Tail).
 1447meta_called([0|MT], [A|AT], [A|CT0], CT) :-
 1448    !,
 1449    meta_called(MT, AT, CT0, CT).
 1450meta_called([I|MT], [A|AT], [A+I|CT0], CT) :-
 1451    integer(I), I>0,
 1452    !,
 1453    meta_called(MT, AT, CT0, CT).
 1454meta_called([_|MT], [_|AT], Called, Tail) :-
 1455    !,
 1456    meta_called(MT, AT, Called, Tail).
 1457
 1458
 1459:- html_meta
 1460    html(html,?,?),
 1461    page(html,?,?),
 1462    page(html,html,?,?),
 1463    page(+,html,html,?,?),
 1464    pagehead(+,html,?,?),
 1465    pagebody(+,html,?,?),
 1466    reply_html_page(html,html),
 1467    reply_html_page(+,html,html),
 1468    html_post(+,html,?,?). 1469
 1470
 1471                 /*******************************
 1472                 *      PCE EMACS SUPPORT       *
 1473                 *******************************/
 1474
 1475:- multifile
 1476    prolog_colour:goal_colours/2,
 1477    prolog_colour:style/2,
 1478    prolog_colour:message//1,
 1479    prolog:called_by/2. 1480
 1481prolog_colour:goal_colours(Goal, Colours) :-
 1482    html_meta_head(Goal, _Module, Head),
 1483    html_meta_colours(Head, Goal, Colours).
 1484prolog_colour:goal_colours(html_meta(_),
 1485                           built_in-[meta_declarations([html])]).
 1486
 1487                                        % TBD: Check with do_expand!
 1488html_colours(Var, classify) :-
 1489    var(Var),
 1490    !.
 1491html_colours(\List, html_raw-[list-Colours]) :-
 1492    is_list(List),
 1493    !,
 1494    list_colours(List, Colours).
 1495html_colours(\_, html_call-[dcg]) :- !.
 1496html_colours(_:Term, built_in-[classify,Colours]) :-
 1497    !,
 1498    html_colours(Term, Colours).
 1499html_colours(&(Entity), functor-[entity(Entity)]) :- !.
 1500html_colours(List, list-ListColours) :-
 1501    List = [_|_],
 1502    !,
 1503    list_colours(List, ListColours).
 1504html_colours(Format-Args, functor-[FormatColor,ArgsColors]) :-
 1505    !,
 1506    format_colours(Format, FormatColor),
 1507    format_arg_colours(Args, Format, ArgsColors).
 1508html_colours(Term, TermColours) :-
 1509    compound(Term),
 1510    compound_name_arguments(Term, Name, Args),
 1511    Name \== '.',
 1512    !,
 1513    (   Args = [One]
 1514    ->  TermColours = html(Name)-ArgColours,
 1515        (   layout(Name, _, empty)
 1516        ->  attr_colours(One, ArgColours)
 1517        ;   html_colours(One, Colours),
 1518            ArgColours = [Colours]
 1519        )
 1520    ;   Args = [AList,Content]
 1521    ->  TermColours = html(Name)-[AColours, Colours],
 1522        attr_colours(AList, AColours),
 1523        html_colours(Content, Colours)
 1524    ;   TermColours = error
 1525    ).
 1526html_colours(_, classify).
 1527
 1528list_colours(Var, classify) :-
 1529    var(Var),
 1530    !.
 1531list_colours([], []).
 1532list_colours([H0|T0], [H|T]) :-
 1533    !,
 1534    html_colours(H0, H),
 1535    list_colours(T0, T).
 1536list_colours(Last, Colours) :-          % improper list
 1537    html_colours(Last, Colours).
 1538
 1539attr_colours(Var, classify) :-
 1540    var(Var),
 1541    !.
 1542attr_colours([], classify) :- !.
 1543attr_colours(Term, list-Elements) :-
 1544    Term = [_|_],
 1545    !,
 1546    attr_list_colours(Term, Elements).
 1547attr_colours(Name=Value, built_in-[html_attribute(Name), VColour]) :-
 1548    !,
 1549    attr_value_colour(Value, VColour).
 1550attr_colours(NS:Term, built_in-[ html_xmlns(NS),
 1551                                 html_attribute(Name)-[classify]
 1552                               ]) :-
 1553    compound(Term),
 1554    compound_name_arity(Term, Name, 1).
 1555attr_colours(Term, html_attribute(Name)-[VColour]) :-
 1556    compound(Term),
 1557    compound_name_arity(Term, Name, 1),
 1558    !,
 1559    Term =.. [Name,Value],
 1560    attr_value_colour(Value, VColour).
 1561attr_colours(Name, html_attribute(Name)) :-
 1562    atom(Name),
 1563    !.
 1564attr_colours(Term, classify) :-
 1565    compound(Term),
 1566    compound_name_arity(Term, '.', 2),
 1567    !.
 1568attr_colours(_, error).
 1569
 1570attr_list_colours(Var, classify) :-
 1571    var(Var),
 1572    !.
 1573attr_list_colours([], []).
 1574attr_list_colours([H0|T0], [H|T]) :-
 1575    attr_colours(H0, H),
 1576    attr_list_colours(T0, T).
 1577
 1578attr_value_colour(Var, classify) :-
 1579    var(Var).
 1580attr_value_colour(location_by_id(ID), sgml_attr_function-[Colour]) :-
 1581    !,
 1582    location_id(ID, Colour).
 1583attr_value_colour(#(ID), sgml_attr_function-[Colour]) :-
 1584    !,
 1585    location_id(ID, Colour).
 1586attr_value_colour(A+B, sgml_attr_function-[CA,CB]) :-
 1587    !,
 1588    attr_value_colour(A, CA),
 1589    attr_value_colour(B, CB).
 1590attr_value_colour(encode(_), sgml_attr_function-[classify]) :- !.
 1591attr_value_colour(Atom, classify) :-
 1592    atomic(Atom),
 1593    !.
 1594attr_value_colour([_|_], classify) :- !.
 1595attr_value_colour(_Fmt-_Args, classify) :- !.
 1596attr_value_colour(Term, classify) :-
 1597    compound(Term),
 1598    compound_name_arity(Term, '.', 2),
 1599    !.
 1600attr_value_colour(_, error).
 1601
 1602location_id(ID, classify) :-
 1603    var(ID),
 1604    !.
 1605:- if(current_predicate(http_location_for_id/1)). 1606location_id(ID, Class) :-
 1607    (   catch(http_location_by_id(ID, Location), _, fail)
 1608    ->  Class = http_location_for_id(Location)
 1609    ;   Class = http_no_location_for_id(ID)
 1610    ).
 1611:- endif. 1612location_id(_, classify).
 1613
 1614format_colours(Format, format_string) :- atom(Format), !.
 1615format_colours(Format, format_string) :- string(Format), !.
 1616format_colours(_Format, type_error(text)).
 1617
 1618format_arg_colours(Args, _Format, classify) :- is_list(Args), !.
 1619format_arg_colours(_, _, type_error(list)).
 1620
 1621:- op(990, xfx, :=).                    % allow compiling without XPCE
 1622:- op(200, fy, @). 1623
 1624prolog_colour:style(html(_),                    [colour(magenta4), bold(true)]).
 1625prolog_colour:style(entity(_),                  [colour(magenta4)]).
 1626prolog_colour:style(html_attribute(_),          [colour(magenta4)]).
 1627prolog_colour:style(html_xmlns(_),              [colour(magenta4)]).
 1628prolog_colour:style(format_string(_),           [colour(magenta4)]).
 1629prolog_colour:style(sgml_attr_function,         [colour(blue)]).
 1630prolog_colour:style(http_location_for_id(_),    [bold(true)]).
 1631prolog_colour:style(http_no_location_for_id(_), [colour(red), bold(true)]).
 1632
 1633
 1634prolog_colour:message(html(Element)) -->
 1635    [ '~w: SGML element'-[Element] ].
 1636prolog_colour:message(entity(Entity)) -->
 1637    [ '~w: SGML entity'-[Entity] ].
 1638prolog_colour:message(html_attribute(Attr)) -->
 1639    [ '~w: SGML attribute'-[Attr] ].
 1640prolog_colour:message(sgml_attr_function) -->
 1641    [ 'SGML Attribute function'-[] ].
 1642prolog_colour:message(http_location_for_id(Location)) -->
 1643    [ 'ID resolves to ~w'-[Location] ].
 1644prolog_colour:message(http_no_location_for_id(ID)) -->
 1645    [ '~w: no such ID'-[ID] ].
 1646
 1647
 1648%       prolog:called_by(+Goal, -Called)
 1649%
 1650%       Hook into library(pce_prolog_xref).  Called is a list of callable
 1651%       or callable+N to indicate (DCG) arglist extension.
 1652
 1653
 1654prolog:called_by(Goal, Called) :-
 1655    html_meta_head(Goal, _Module, Head),
 1656    html_meta_called(Head, Goal, Called).
 1657
 1658called_by(Term) -->
 1659    called_by(Term, _).
 1660
 1661called_by(Var, _) -->
 1662    { var(Var) },
 1663    !,
 1664    [].
 1665called_by(\G, M) -->
 1666    !,
 1667    (   { is_list(G) }
 1668    ->  called_by(G, M)
 1669    ;   {atom(M)}
 1670    ->  [(M:G)+2]
 1671    ;   [G+2]
 1672    ).
 1673called_by([], _) -->
 1674    !,
 1675    [].
 1676called_by([H|T], M) -->
 1677    !,
 1678    called_by(H, M),
 1679    called_by(T, M).
 1680called_by(M:Term, _) -->
 1681    !,
 1682    (   {atom(M)}
 1683    ->  called_by(Term, M)
 1684    ;   []
 1685    ).
 1686called_by(Term, M) -->
 1687    { compound(Term),
 1688      !,
 1689      Term =.. [_|Args]
 1690    },
 1691    called_by(Args, M).
 1692called_by(_, _) -->
 1693    [].
 1694
 1695:- multifile
 1696    prolog:hook/1. 1697
 1698prolog:hook(body(_,_,_)).
 1699prolog:hook(body(_,_,_,_)).
 1700prolog:hook(head(_,_,_)).
 1701prolog:hook(head(_,_,_,_)).
 1702
 1703
 1704                 /*******************************
 1705                 *            MESSAGES          *
 1706                 *******************************/
 1707
 1708:- multifile
 1709    prolog:message/3. 1710
 1711prolog:message(html(expand_failed(What))) -->
 1712    [ 'Failed to translate to HTML: ~p'-[What] ].
 1713prolog:message(html(wrong_encoding(Stream, Enc))) -->
 1714    [ 'XHTML demands UTF-8 encoding; encoding of ~p is ~w'-[Stream, Enc] ].
 1715prolog:message(html(multiple_receivers(Id))) -->
 1716    [ 'html_post//2: multiple receivers for: ~p'-[Id] ].
 1717prolog:message(html(no_receiver(Id))) -->
 1718    [ 'html_post//2: no receivers for: ~p'-[Id] ]