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