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