View source with raw comments or as raw
    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

Write HTML text

The purpose of this library is to simplify writing HTML pages. Of course, it is possible to use format/3 to write to the HTML stream directly, but this is generally not very satisfactory:

This module tries to remedy these problems. The idea is to translate a Prolog term into an HTML document. We use DCG for most of the generation.

International documents

The library supports the generation of international documents, but this is currently limited to using UTF-8 encoded HTML or XHTML documents. It is strongly recommended to use the following mime-type.

Content-type: text/html; charset=UTF-8

When generating XHTML documents, the output stream must be in UTF-8 encoding. */

  132                 /*******************************
  133                 *            SETTINGS          *
  134                 *******************************/
 html_set_options(+Options) is det
Set options for the HTML output. Options are stored in prolog flags to ensure proper multi-threaded behaviour where setting an option is local to the thread and new threads start with the options from the parent thread. Defined options are:
dialect(Dialect)
One of html4, xhtml or html5 (default). For compatibility reasons, html is accepted as an alias for html4.
doctype(+DocType)
Set the <|DOCTYPE DocType > line for page//1 and page//2.
content_type(+ContentType)
Set the Content-type for reply_html_page/3

Note that the doctype and content_type flags are covered by distinct prolog flags: html4_doctype, xhtml_doctype and html5_doctype and similar for the content type. The Dialect must be switched before doctype and content type.

  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).
 html_current_option(?Option) is nondet
True if Option is an active option for the HTML generator.
  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').
 init_options is det
Initialise the HTML processing options.
  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.
 xml_header(-Header)
First line of XHTML document. Added by print_html/1.
  251xml_header('<?xml version=\'1.0\' encoding=\'UTF-8\'?>').
 ns(?Which, ?Atom)
Namespace declarations
  257ns(xhtml, 'http://www.w3.org/1999/xhtml').
  258
  259
  260                 /*******************************
  261                 *             PAGE             *
  262                 *******************************/
 page(+Content:dom)// is det
 page(+Head:dom, +Body:dom)// is det
Generate a page including the HTML <!DOCTYPE> header. The actual doctype is read from the option doctype as defined by html_set_options/1.
  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).
 doctype//
Emit the <DOCTYPE ... header. The doctype comes from the option doctype(DOCTYPE) (see html_set_options/1). Setting the doctype to '' (empty atom) suppresses the header completely. This is to avoid a IE bug in processing AJAX output ...
  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).
 html(+Content:dom)// is det
Generate HTML from Content. Generates a token sequence for print_html/2.
  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).
 raw(+List, +Module)// is det
Emit unquoted (raw) output used for scripts, etc.
  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].
 html_begin(+Env)// is det
 html_end(+End)// is det
For html_begin//1, Env is a term Env(Attributes); for html_end//1 it is the plain environment name. Used for exceptional cases. Normal applications use html//1. The following two fragments are identical, where we prefer the first as it is more concise and less error-prone.
        html(table(border=1, \table_content))
        html_begin(table(border=1)
        table_content,
        html_end(table)
  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).
 xhtml_empty(+Env, +Attributes)// is det
Emit element in xhtml mode with empty content.
  585xhtml_empty(Env, Attributes) -->
  586    pre_open(Env),
  587    [<],
  588    [Env],
  589    attributes(Attributes),
  590    ['/>'].
 xhtml_ns(+Id, +Value)//
Demand an xmlns:id=Value in the outer html tag. This uses the html_post/2 mechanism to post to the xmlns channel. Rdfa (http://www.w3.org/2006/07/SWD/RDFa/syntax/), embedding RDF in (x)html provides a typical usage scenario where we want to publish the required namespaces in the header. We can define:
rdf_ns(Id) -->
        { rdf_global_id(Id:'', Value) },
        xhtml_ns(Id, Value).

After which we can use rdf_ns//1 as a normal rule in html//1 to publish namespaces from library(semweb/rdf_db). Note that this macro only has effect if the dialect is set to xhtml. In html mode it is silently ignored.

The required xmlns receiver is installed by html_begin//1 using the html tag and thus is present in any document that opens the outer html environment through this library.

  615xhtml_ns(Id, Value) -->
  616    { html_current_option(dialect(xhtml)) },
  617    !,
  618    html_post(xmlns, \attribute(xmlns:Id=Value)).
  619xhtml_ns(_, _) -->
  620    [].
 html_root_attribute(+Name, +Value)//
Add an attribute to the HTML root element of the page. For example:
    html(div(...)),
    html_root_attribute(lang, en),
    ...
  633html_root_attribute(Name, Value) -->
  634    html_post(html_begin, \attribute(Name=Value)).
 attributes(+Env, +Attributes)// is det
Emit attributes for Env. Adds XHTML namespace declaration to the html tag if not provided by the caller.
  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 ].
 attribute_value(+Value) is det
Print an attribute value. Value is either atomic or one of the following terms:

The hook expand_attribute_value//1 can be defined to provide additional `function like' translations. For example, http_dispatch.pl defines location_by_id(ID) to refer to a location on the current server based on the handler id. See http_location_by_id/2.

  714attribute_value(List) -->
  715    { is_list(List) },
  716    !,
  717    attribute_value_m(List).
  718attribute_value(Value) -->
  719    attribute_value_s(Value).
  720
  721% emit a single attribute value
  722
  723attribute_value_s(Var) -->
  724    { var(Var),
  725      !,
  726      instantiation_error(Var)
  727    }.
  728attribute_value_s(A+B) -->
  729    !,
  730    attribute_value(A),
  731    (   { is_list(B) }
  732    ->  (   { B == [] }
  733        ->  []
  734        ;   [?], search_parameters(B)
  735        )
  736    ;   attribute_value(B)
  737    ).
  738attribute_value_s(encode(Value)) -->
  739    !,
  740    { uri_encoded(query_value, Value, Encoded) },
  741    [ Encoded ].
  742attribute_value_s(Value) -->
  743    expand_attribute_value(Value),
  744    !.
  745attribute_value_s(Fmt-Args) -->
  746    !,
  747    { format(string(Value), Fmt, Args) },
  748    html_quoted_attribute(Value).
  749attribute_value_s(Value) -->
  750    html_quoted_attribute(Value).
  751
  752search_parameters([H|T]) -->
  753    search_parameter(H),
  754    (   {T == []}
  755    ->  []
  756    ;   ['&amp;'],
  757        search_parameters(T)
  758    ).
  759
  760search_parameter(Var) -->
  761    { var(Var),
  762      !,
  763      instantiation_error(Var)
  764    }.
  765search_parameter(Name=Value) -->
  766    { www_form_encode(Value, Encoded) },
  767    [Name, =, Encoded].
  768search_parameter(Term) -->
  769    { Term =.. [Name, Value],
  770      !,
  771      www_form_encode(Value, Encoded)
  772    },
  773    [Name, =, Encoded].
  774search_parameter(Term) -->
  775    { domain_error(search_parameter, Term)
  776    }.
 attribute_value_m(+List)//
Used for multi-valued attributes, such as class-lists. E.g.,
      body(class([c1, c2]), Body)

Emits <body class="c1 c2"> ...

  788attribute_value_m([]) -->
  789    [].
  790attribute_value_m([H|T]) -->
  791    attribute_value_s(H),
  792    (   { T == [] }
  793    ->  []
  794    ;   [' '],
  795        attribute_value_m(T)
  796    ).
  797
  798
  799                 /*******************************
  800                 *         QUOTING RULES        *
  801                 *******************************/
 html_quoted(Text)// is det
Quote the value for normal (CDATA) text. Note that text appearing in the document structure is normally quoted using these rules. I.e. the following emits properly quoted bold text regardless of the content of Text:
        html(b(Text))
To be done
- Assumes UTF-8 encoding of the output.
  816html_quoted(Text) -->
  817    { xml_quote_cdata(Text, Quoted, utf8) },
  818    [ Quoted ].
 html_quoted_attribute(+Text)// is det
Quote the value according to the rules for tag-attributes included in double-quotes. Note that -like html_quoted//1-, attributed values printed through html//1 are quoted atomatically.
To be done
- Assumes UTF-8 encoding of the output.
  829html_quoted_attribute(Text) -->
  830    { xml_quote_attribute(Text, Quoted, utf8) },
  831    [ Quoted ].
 cdata_element(?Element)
True when Element contains declared CDATA and thus only </ needs to be escaped.
  838cdata_element(script).
  839cdata_element(style).
  840
  841
  842                 /*******************************
  843                 *      REPOSITIONING HTML      *
  844                 *******************************/
 html_post(+Id, :HTML)// is det
Reposition HTML to the receiving Id. The html_post//2 call processes HTML using html//1. Embedded \-commands are executed by mailman/1 from print_html/1 or html_print_length/2. These commands are called in the calling context of the html_post//2 call.

A typical usage scenario is to get required CSS links in the document head in a reusable fashion. First, we define css//1 as:

css(URL) -->
        html_post(css,
                  link([ type('text/css'),
                         rel('stylesheet'),
                         href(URL)
                       ])).

Next we insert the unique CSS links, in the pagehead using the following call to reply_html_page/2:

        reply_html_page([ title(...),
                          \html_receive(css)
                        ],
                        ...)
  876html_post(Id, Content) -->
  877    { strip_module(Content, M, C) },
  878    [ mailbox(Id, post(M, C)) ].
 html_receive(+Id)// is det
Receive posted HTML tokens. Unique sequences of tokens posted with html_post//2 are inserted at the location where html_receive//1 appears.
See also
- The local predicate sorted_html//1 handles the output of html_receive//1.
- html_receive//2 allows for post-processing the posted material.
  891html_receive(Id) -->
  892    html_receive(Id, sorted_html).
 html_receive(+Id, :Handler)// is det
This extended version of html_receive//1 causes Handler to be called to process all messages posted to the channal at the time output is generated. Handler is called as below, where PostedTerms is a list of Module:Term created from calls to html_post//2. Module is the context module of html_post and Term is the unmodified term. Members in PostedTerms are in the order posted and may contain duplicates.
  phrase(Handler, PostedTerms, HtmlTerms, Rest)

Typically, Handler collects the posted terms, creating a term suitable for html//1 and finally calls html//1.

  911html_receive(Id, Handler) -->
  912    { strip_module(Handler, M, P) },
  913    [ mailbox(Id, accept(M:P, _)) ].
 html_noreceive(+Id)// is det
As html_receive//1, but discard posted messages.
  919html_noreceive(Id) -->
  920    [ mailbox(Id, ignore(_,_)) ].
 mailman(+Tokens) is det
Collect posted tokens and copy them into the receiving mailboxes. Mailboxes may produce output for each other, but not cyclic. The current scheme to resolve this is rather naive: It simply permutates the mailbox resolution order until it found a working one. Before that, it puts head and script boxes at the end.
  931mailman(Tokens) :-
  932    (   html_token(mailbox(_, accept(_, Accepted)), Tokens)
  933    ->  true
  934    ),
  935    var(Accepted),                 % not yet executed
  936    !,
  937    mailboxes(Tokens, Boxes),
  938    keysort(Boxes, Keyed),
  939    group_pairs_by_key(Keyed, PerKey),
  940    move_last(PerKey, script, PerKey1),
  941    move_last(PerKey1, head, PerKey2),
  942    (   permutation(PerKey2, PerKeyPerm),
  943        (   mail_ids(PerKeyPerm)
  944        ->  !
  945        ;   debug(html(mailman),
  946                  'Failed mail delivery order; retrying', []),
  947            fail
  948        )
  949    ->  true
  950    ;   print_message(error, html(cyclic_mailboxes))
  951    ).
  952mailman(_).
  953
  954move_last(Box0, Id, Box) :-
  955    selectchk(Id-List, Box0, Box1),
  956    !,
  957    append(Box1, [Id-List], Box).
  958move_last(Box, _, Box).
 html_token(?Token, +Tokens) is nondet
True if Token is a token in the token set. This is like member, but the toplevel list may contain cdata(Elem, Tokens).
  965html_token(Token, [H|T]) :-
  966    html_token_(T, H, Token).
  967
  968html_token_(_, Token, Token) :- !.
  969html_token_(_, cdata(_,Tokens), Token) :-
  970    html_token(Token, Tokens).
  971html_token_([H|T], _, Token) :-
  972    html_token_(T, H, Token).
 mailboxes(+Tokens, -MailBoxes) is det
Get all mailboxes from the token set.
  978mailboxes(Tokens, MailBoxes) :-
  979    mailboxes(Tokens, MailBoxes, []).
  980
  981mailboxes([], List, List).
  982mailboxes([mailbox(Id, Value)|T0], [Id-Value|T], Tail) :-
  983    !,
  984    mailboxes(T0, T, Tail).
  985mailboxes([cdata(_Type, Tokens)|T0], Boxes, Tail) :-
  986    !,
  987    mailboxes(Tokens, Boxes, Tail0),
  988    mailboxes(T0, Tail0, Tail).
  989mailboxes([_|T0], T, Tail) :-
  990    mailboxes(T0, T, Tail).
  991
  992mail_ids([]).
  993mail_ids([H|T0]) :-
  994    mail_id(H, NewPosts),
  995    add_new_posts(NewPosts, T0, T),
  996    mail_ids(T).
  997
  998mail_id(Id-List, NewPosts) :-
  999    mail_handlers(List, Boxes, Content),
 1000    (   Boxes = [accept(MH:Handler, In)]
 1001    ->  extend_args(Handler, Content, Goal),
 1002        phrase(MH:Goal, In),
 1003        mailboxes(In, NewBoxes),
 1004        keysort(NewBoxes, Keyed),
 1005        group_pairs_by_key(Keyed, NewPosts)
 1006    ;   Boxes = [ignore(_, _)|_]
 1007    ->  NewPosts = []
 1008    ;   Boxes = [accept(_,_),accept(_,_)|_]
 1009    ->  print_message(error, html(multiple_receivers(Id))),
 1010        NewPosts = []
 1011    ;   print_message(error, html(no_receiver(Id))),
 1012        NewPosts = []
 1013    ).
 1014
 1015add_new_posts([], T, T).
 1016add_new_posts([Id-Posts|NewT], T0, T) :-
 1017    (   select(Id-List0, T0, Id-List, T1)
 1018    ->  append(List0, Posts, List)
 1019    ;   debug(html(mailman), 'Stuck with new posts on ~q', [Id]),
 1020        fail
 1021    ),
 1022    add_new_posts(NewT, T1, T).
 mail_handlers(+Boxes, -Handlers, -Posters) is det
Collect all post(Module,HTML) into Posters and the remainder in Handlers. Handlers consists of accept(Handler, Tokens) and ignore(_,_).
 1031mail_handlers([], [], []).
 1032mail_handlers([post(Module,HTML)|T0], H, [Module:HTML|T]) :-
 1033    !,
 1034    mail_handlers(T0, H, T).
 1035mail_handlers([H|T0], [H|T], C) :-
 1036    mail_handlers(T0, T, C).
 1037
 1038extend_args(Term, Extra, NewTerm) :-
 1039    Term =.. [Name|Args],
 1040    append(Args, [Extra], NewArgs),
 1041    NewTerm =.. [Name|NewArgs].
 sorted_html(+Content:list)// is det
Default handlers for html_receive//1. It sorts the posted objects to create a unique list.
bug
- Elements can differ just on the module. Ideally we should phrase all members, sort the list of list of tokens and emit the result. Can we do better?
 1052sorted_html(List) -->
 1053    { sort(List, Unique) },
 1054    html(Unique).
 head_html(+Content:list)// is det
Handler for html_receive(head). Unlike sorted_html//1, it calls a user hook html_head_expansion/2 to process the collected head material into a term suitable for html//1.
To be done
- This has been added to facilitate html_head.pl, an experimental library for dealing with css and javascript resources. It feels a bit like a hack, but for now I do not know a better solution.
 1067head_html(List) -->
 1068    { list_to_set(List, Unique),
 1069      html_expand_head(Unique, NewList)
 1070    },
 1071    html(NewList).
 1072
 1073:- multifile
 1074    html_head_expansion/2. 1075
 1076html_expand_head(List0, List) :-
 1077    html_head_expansion(List0, List1),
 1078    List0 \== List1,
 1079    !,
 1080    html_expand_head(List1, List).
 1081html_expand_head(List, List).
 1082
 1083
 1084                 /*******************************
 1085                 *             LAYOUT           *
 1086                 *******************************/
 1087
 1088pre_open(Env) -->
 1089    { layout(Env, N-_, _)
 1090    },
 1091    !,
 1092    [ nl(N) ].
 1093pre_open(_) --> [].
 1094
 1095post_open(Env) -->
 1096    { layout(Env, _-N, _)
 1097    },
 1098    !,
 1099    [ nl(N) ].
 1100post_open(_) -->
 1101    [].
 1102
 1103pre_close(head) -->
 1104    !,
 1105    html_receive(head, head_html),
 1106    { layout(head, _, N-_) },
 1107    [ nl(N) ].
 1108pre_close(Env) -->
 1109    { layout(Env, _, N-_)
 1110    },
 1111    !,
 1112    [ nl(N) ].
 1113pre_close(_) -->
 1114    [].
 1115
 1116post_close(Env) -->
 1117    { layout(Env, _, _-N)
 1118    },
 1119    !,
 1120    [ nl(N) ].
 1121post_close(_) -->
 1122    [].
 layout(+Tag, -Open, -Close) is det
Define required newlines before and after tags. This table is rather incomplete. New rules can be added to this multifile predicate.
Arguments:
Tag- Name of the tag
Open- Tuple M-N, where M is the number of lines before the tag and N after.
Close- Either as Open, or the atom - (minus) to omit the close-tag or empty to indicate the element has no content model.
To be done
- Complete table
 1139:- multifile
 1140    layout/3. 1141
 1142layout(table,      2-1, 1-2).
 1143layout(blockquote, 2-1, 1-2).
 1144layout(pre,        2-1, 0-2).
 1145layout(textarea,   1-1, 0-1).
 1146layout(center,     2-1, 1-2).
 1147layout(dl,         2-1, 1-2).
 1148layout(ul,         1-1, 1-1).
 1149layout(ol,         2-1, 1-2).
 1150layout(form,       2-1, 1-2).
 1151layout(frameset,   2-1, 1-2).
 1152layout(address,    2-1, 1-2).
 1153
 1154layout(head,       1-1, 1-1).
 1155layout(body,       1-1, 1-1).
 1156layout(script,     1-1, 1-1).
 1157layout(style,      1-1, 1-1).
 1158layout(select,     1-1, 1-1).
 1159layout(map,        1-1, 1-1).
 1160layout(html,       1-1, 1-1).
 1161layout(caption,    1-1, 1-1).
 1162layout(applet,     1-1, 1-1).
 1163
 1164layout(tr,         1-0, 0-1).
 1165layout(option,     1-0, 0-1).
 1166layout(li,         1-0, 0-1).
 1167layout(dt,         1-0, -).
 1168layout(dd,         0-0, -).
 1169layout(title,      1-0, 0-1).
 1170
 1171layout(h1,         2-0, 0-2).
 1172layout(h2,         2-0, 0-2).
 1173layout(h3,         2-0, 0-2).
 1174layout(h4,         2-0, 0-2).
 1175
 1176layout(iframe,     1-1, 1-1).
 1177
 1178layout(hr,         1-1, empty).         % empty elements
 1179layout(br,         0-1, empty).
 1180layout(img,        0-0, empty).
 1181layout(meta,       1-1, empty).
 1182layout(base,       1-1, empty).
 1183layout(link,       1-1, empty).
 1184layout(input,      0-0, empty).
 1185layout(frame,      1-1, empty).
 1186layout(col,        0-0, empty).
 1187layout(area,       1-0, empty).
 1188layout(input,      1-0, empty).
 1189layout(param,      1-0, empty).
 1190
 1191layout(p,          2-1, -).             % omited close
 1192layout(td,         0-0, 0-0).
 1193
 1194layout(div,        1-0, 0-1).
 1195
 1196                 /*******************************
 1197                 *           PRINTING           *
 1198                 *******************************/
 print_html(+List) is det
 print_html(+Out:stream, +List) is det
Print list of atoms and layout instructions. Currently used layout instructions:
nl(N)
Use at minimum N newlines here.
mailbox(Id, Box)
Repositioned tokens (see html_post//2 and html_receive//2)
 1213print_html(List) :-
 1214    current_output(Out),
 1215    mailman(List),
 1216    write_html(List, Out).
 1217print_html(Out, List) :-
 1218    (   html_current_option(dialect(xhtml))
 1219    ->  stream_property(Out, encoding(Enc)),
 1220        (   Enc == utf8
 1221        ->  true
 1222        ;   print_message(warning, html(wrong_encoding(Out, Enc)))
 1223        ),
 1224        xml_header(Hdr),
 1225        write(Out, Hdr), nl(Out)
 1226    ;   true
 1227    ),
 1228    mailman(List),
 1229    write_html(List, Out),
 1230    flush_output(Out).
 1231
 1232write_html([], _).
 1233write_html([nl(N)|T], Out) :-
 1234    !,
 1235    join_nl(T, N, Lines, T2),
 1236    write_nl(Lines, Out),
 1237    write_html(T2, Out).
 1238write_html([mailbox(_, Box)|T], Out) :-
 1239    !,
 1240    (   Box = accept(_, Accepted)
 1241    ->  write_html(Accepted, Out)
 1242    ;   true
 1243    ),
 1244    write_html(T, Out).
 1245write_html([cdata(Env, Tokens)|T], Out) :-
 1246    !,
 1247    with_output_to(string(CDATA), write_html(Tokens, current_output)),
 1248    valid_cdata(Env, CDATA),
 1249    write(Out, CDATA),
 1250    write_html(T, Out).
 1251write_html([H|T], Out) :-
 1252    write(Out, H),
 1253    write_html(T, Out).
 1254
 1255join_nl([nl(N0)|T0], N1, N, T) :-
 1256    !,
 1257    N2 is max(N0, N1),
 1258    join_nl(T0, N2, N, T).
 1259join_nl(L, N, N, L).
 1260
 1261write_nl(0, _) :- !.
 1262write_nl(N, Out) :-
 1263    nl(Out),
 1264    N1 is N - 1,
 1265    write_nl(N1, Out).
 valid_cdata(+Env, +String) is det
True when String is valid content for a CDATA element such as <script>. This implies it cannot contain </script/. There is no escape for this and the script generator must use a work-around using features of the script language. For example, when using JavaScript, "</script>" can be written as "<\/script>".
Errors
- domain_error(cdata, String)
See also
- write_json/2, js_arg//1.
 1279valid_cdata(Env, String) :-
 1280    atomics_to_string(['</', Env, '>'], End),
 1281    sub_atom_icasechk(String, _, End),
 1282    !,
 1283    domain_error(cdata, String).
 1284valid_cdata(_, _).
 html_print_length(+List, -Len) is det
Determine the content length of a token list produced using html//1. Here is an example on how this is used to output an HTML compatible to HTTP:
        phrase(html(DOM), Tokens),
        html_print_length(Tokens, Len),
        format('Content-type: text/html; charset=UTF-8~n'),
        format('Content-length: ~d~n~n', [Len]),
        print_html(Tokens)
 1300html_print_length(List, Len) :-
 1301    mailman(List),
 1302    (   html_current_option(dialect(xhtml))
 1303    ->  xml_header(Hdr),
 1304        atom_length(Hdr, L0),
 1305        L1 is L0+1                  % one for newline
 1306    ;   L1 = 0
 1307    ),
 1308    html_print_length(List, L1, Len).
 1309
 1310html_print_length([], L, L).
 1311html_print_length([nl(N)|T], L0, L) :-
 1312    !,
 1313    join_nl(T, N, Lines, T1),
 1314    L1 is L0 + Lines,               % assume only \n!
 1315    html_print_length(T1, L1, L).
 1316html_print_length([mailbox(_, Box)|T], L0, L) :-
 1317    !,
 1318    (   Box = accept(_, Accepted)
 1319    ->  html_print_length(Accepted, L0, L1)
 1320    ;   L1 = L0
 1321    ),
 1322    html_print_length(T, L1, L).
 1323html_print_length([cdata(_, CDATA)|T], L0, L) :-
 1324    !,
 1325    html_print_length(CDATA, L0, L1),
 1326    html_print_length(T, L1, L).
 1327html_print_length([H|T], L0, L) :-
 1328    atom_length(H, Hlen),
 1329    L1 is L0+Hlen,
 1330    html_print_length(T, L1, L).
 reply_html_page(:Head, :Body) is det
 reply_html_page(+Style, :Head, :Body) is det
Provide the complete reply as required by http_wrapper.pl for a page constructed from Head and Body. The HTTP Content-type is provided by html_current_option/1.
 1340reply_html_page(Head, Body) :-
 1341    reply_html_page(default, Head, Body).
 1342reply_html_page(Style, Head, Body) :-
 1343    html_current_option(content_type(Type)),
 1344    phrase(page(Style, Head, Body), HTML),
 1345    format('Content-type: ~w~n~n', [Type]),
 1346    print_html(HTML).
 1347
 1348
 1349                 /*******************************
 1350                 *     META-PREDICATE SUPPORT   *
 1351                 *******************************/
 html_meta(+Heads) is det
This directive can be used to declare that an HTML rendering rule takes HTML content as argument. It has two effects. It emits the appropriate meta_predicate/1 and instructs the built-in editor (PceEmacs) to provide proper colouring for the arguments. The arguments in Head are the same as for meta_predicate or can be constant html. For example:
:- html_meta
      page(html,html,?,?).
 1367html_meta(Spec) :-
 1368    throw(error(context_error(nodirective, html_meta(Spec)), _)).
 1369
 1370html_meta_decls(Var, _, _) :-
 1371    var(Var),
 1372    !,
 1373    instantiation_error(Var).
 1374html_meta_decls((A,B), (MA,MB), [MH|T]) :-
 1375    !,
 1376    html_meta_decl(A, MA, MH),
 1377    html_meta_decls(B, MB, T).
 1378html_meta_decls(A, MA, [MH]) :-
 1379    html_meta_decl(A, MA, MH).
 1380
 1381html_meta_decl(Head, MetaHead,
 1382               html_write:html_meta_head(GenHead, Module, Head)) :-
 1383    functor(Head, Name, Arity),
 1384    functor(GenHead, Name, Arity),
 1385    prolog_load_context(module, Module),
 1386    Head =.. [Name|HArgs],
 1387    maplist(html_meta_decl, HArgs, MArgs),
 1388    MetaHead =.. [Name|MArgs].
 1389
 1390html_meta_decl(html, :) :- !.
 1391html_meta_decl(Meta, Meta).
 1392
 1393system:term_expansion((:- html_meta(Heads)),
 1394                      [ (:- meta_predicate(Meta))
 1395                      | MetaHeads
 1396                      ]) :-
 1397    html_meta_decls(Heads, Meta, MetaHeads).
 1398
 1399:- multifile
 1400    html_meta_head/3. 1401
 1402html_meta_colours(Head, Goal, built_in-Colours) :-
 1403    Head =.. [_|MArgs],
 1404    Goal =.. [_|Args],
 1405    maplist(meta_colours, MArgs, Args, Colours).
 1406
 1407meta_colours(html, HTML, Colours) :-
 1408    !,
 1409    html_colours(HTML, Colours).
 1410meta_colours(I, _, Colours) :-
 1411    integer(I), I>=0,
 1412    !,
 1413    Colours = meta(I).
 1414meta_colours(_, _, classify).
 1415
 1416html_meta_called(Head, Goal, Called) :-
 1417    Head =.. [_|MArgs],
 1418    Goal =.. [_|Args],
 1419    meta_called(MArgs, Args, Called, []).
 1420
 1421meta_called([], [], Called, Called).
 1422meta_called([html|MT], [A|AT], Called, Tail) :-
 1423    !,
 1424    phrase(called_by(A), Called, Tail1),
 1425    meta_called(MT, AT, Tail1, Tail).
 1426meta_called([0|MT], [A|AT], [A|CT0], CT) :-
 1427    !,
 1428    meta_called(MT, AT, CT0, CT).
 1429meta_called([I|MT], [A|AT], [A+I|CT0], CT) :-
 1430    integer(I), I>0,
 1431    !,
 1432    meta_called(MT, AT, CT0, CT).
 1433meta_called([_|MT], [_|AT], Called, Tail) :-
 1434    !,
 1435    meta_called(MT, AT, Called, Tail).
 1436
 1437
 1438:- html_meta
 1439    html(html,?,?),
 1440    page(html,?,?),
 1441    page(html,html,?,?),
 1442    page(+,html,html,?,?),
 1443    pagehead(+,html,?,?),
 1444    pagebody(+,html,?,?),
 1445    reply_html_page(html,html),
 1446    reply_html_page(+,html,html),
 1447    html_post(+,html,?,?). 1448
 1449
 1450                 /*******************************
 1451                 *      PCE EMACS SUPPORT       *
 1452                 *******************************/
 1453
 1454:- multifile
 1455    prolog_colour:goal_colours/2,
 1456    prolog_colour:style/2,
 1457    prolog_colour:message//1,
 1458    prolog:called_by/2. 1459
 1460prolog_colour:goal_colours(Goal, Colours) :-
 1461    html_meta_head(Goal, _Module, Head),
 1462    html_meta_colours(Head, Goal, Colours).
 1463prolog_colour:goal_colours(html_meta(_),
 1464                           built_in-[meta_declarations([html])]).
 1465
 1466                                        % TBD: Check with do_expand!
 1467html_colours(Var, classify) :-
 1468    var(Var),
 1469    !.
 1470html_colours(\List, html_raw-[list-Colours]) :-
 1471    is_list(List),
 1472    !,
 1473    list_colours(List, Colours).
 1474html_colours(\_, html_call-[dcg]) :- !.
 1475html_colours(_:Term, built_in-[classify,Colours]) :-
 1476    !,
 1477    html_colours(Term, Colours).
 1478html_colours(&(Entity), functor-[entity(Entity)]) :- !.
 1479html_colours(List, list-ListColours) :-
 1480    List = [_|_],
 1481    !,
 1482    list_colours(List, ListColours).
 1483html_colours(Format-Args, functor-[FormatColor,ArgsColors]) :-
 1484    !,
 1485    format_colours(Format, FormatColor),
 1486    format_arg_colours(Args, Format, ArgsColors).
 1487html_colours(Term, TermColours) :-
 1488    compound(Term),
 1489    compound_name_arguments(Term, Name, Args),
 1490    Name \== '.',
 1491    !,
 1492    (   Args = [One]
 1493    ->  TermColours = html(Name)-ArgColours,
 1494        (   layout(Name, _, empty)
 1495        ->  attr_colours(One, ArgColours)
 1496        ;   html_colours(One, Colours),
 1497            ArgColours = [Colours]
 1498        )
 1499    ;   Args = [AList,Content]
 1500    ->  TermColours = html(Name)-[AColours, Colours],
 1501        attr_colours(AList, AColours),
 1502        html_colours(Content, Colours)
 1503    ;   TermColours = error
 1504    ).
 1505html_colours(_, classify).
 1506
 1507list_colours(Var, classify) :-
 1508    var(Var),
 1509    !.
 1510list_colours([], []).
 1511list_colours([H0|T0], [H|T]) :-
 1512    !,
 1513    html_colours(H0, H),
 1514    list_colours(T0, T).
 1515list_colours(Last, Colours) :-          % improper list
 1516    html_colours(Last, Colours).
 1517
 1518attr_colours(Var, classify) :-
 1519    var(Var),
 1520    !.
 1521attr_colours([], classify) :- !.
 1522attr_colours(Term, list-Elements) :-
 1523    Term = [_|_],
 1524    !,
 1525    attr_list_colours(Term, Elements).
 1526attr_colours(Name=Value, built_in-[html_attribute(Name), VColour]) :-
 1527    !,
 1528    attr_value_colour(Value, VColour).
 1529attr_colours(NS:Term, built_in-[ html_xmlns(NS),
 1530                                 html_attribute(Name)-[classify]
 1531                               ]) :-
 1532    compound(Term),
 1533    compound_name_arity(Term, Name, 1).
 1534attr_colours(Term, html_attribute(Name)-[VColour]) :-
 1535    compound(Term),
 1536    compound_name_arity(Term, Name, 1),
 1537    !,
 1538    Term =.. [Name,Value],
 1539    attr_value_colour(Value, VColour).
 1540attr_colours(Name, html_attribute(Name)) :-
 1541    atom(Name),
 1542    !.
 1543attr_colours(Term, classify) :-
 1544    compound(Term),
 1545    compound_name_arity(Term, '.', 2),
 1546    !.
 1547attr_colours(_, error).
 1548
 1549attr_list_colours(Var, classify) :-
 1550    var(Var),
 1551    !.
 1552attr_list_colours([], []).
 1553attr_list_colours([H0|T0], [H|T]) :-
 1554    attr_colours(H0, H),
 1555    attr_list_colours(T0, T).
 1556
 1557attr_value_colour(Var, classify) :-
 1558    var(Var).
 1559attr_value_colour(location_by_id(ID), sgml_attr_function-[Colour]) :-
 1560    !,
 1561    location_id(ID, Colour).
 1562attr_value_colour(#(ID), sgml_attr_function-[Colour]) :-
 1563    !,
 1564    location_id(ID, Colour).
 1565attr_value_colour(A+B, sgml_attr_function-[CA,CB]) :-
 1566    !,
 1567    attr_value_colour(A, CA),
 1568    attr_value_colour(B, CB).
 1569attr_value_colour(encode(_), sgml_attr_function-[classify]) :- !.
 1570attr_value_colour(Atom, classify) :-
 1571    atomic(Atom),
 1572    !.
 1573attr_value_colour([_|_], classify) :- !.
 1574attr_value_colour(_Fmt-_Args, classify) :- !.
 1575attr_value_colour(Term, classify) :-
 1576    compound(Term),
 1577    compound_name_arity(Term, '.', 2),
 1578    !.
 1579attr_value_colour(_, error).
 1580
 1581location_id(ID, classify) :-
 1582    var(ID),
 1583    !.
 1584location_id(ID, Class) :-
 1585    (   current_predicate(http_dispatch:http_location_by_id/2),
 1586        catch(http_dispatch:http_location_by_id(ID, Location), _, fail)
 1587    ->  Class = http_location_for_id(Location)
 1588    ;   Class = http_no_location_for_id(ID)
 1589    ).
 1590location_id(_, classify).
 1591
 1592format_colours(Format, format_string) :- atom(Format), !.
 1593format_colours(Format, format_string) :- string(Format), !.
 1594format_colours(_Format, type_error(text)).
 1595
 1596format_arg_colours(Args, _Format, classify) :- is_list(Args), !.
 1597format_arg_colours(_, _, type_error(list)).
 1598
 1599:- op(990, xfx, :=).                    % allow compiling without XPCE
 1600:- op(200, fy, @). 1601
 1602prolog_colour:style(html(_),                    [colour(magenta4), bold(true)]).
 1603prolog_colour:style(entity(_),                  [colour(magenta4)]).
 1604prolog_colour:style(html_attribute(_),          [colour(magenta4)]).
 1605prolog_colour:style(html_xmlns(_),              [colour(magenta4)]).
 1606prolog_colour:style(format_string(_),           [colour(magenta4)]).
 1607prolog_colour:style(sgml_attr_function,         [colour(blue)]).
 1608prolog_colour:style(http_location_for_id(_),    [bold(true)]).
 1609prolog_colour:style(http_no_location_for_id(_), [colour(red), bold(true)]).
 1610
 1611
 1612prolog_colour:message(html(Element)) -->
 1613    [ '~w: SGML element'-[Element] ].
 1614prolog_colour:message(entity(Entity)) -->
 1615    [ '~w: SGML entity'-[Entity] ].
 1616prolog_colour:message(html_attribute(Attr)) -->
 1617    [ '~w: SGML attribute'-[Attr] ].
 1618prolog_colour:message(sgml_attr_function) -->
 1619    [ 'SGML Attribute function'-[] ].
 1620prolog_colour:message(http_location_for_id(Location)) -->
 1621    [ 'ID resolves to ~w'-[Location] ].
 1622prolog_colour:message(http_no_location_for_id(ID)) -->
 1623    [ '~w: no such ID'-[ID] ].
 1624
 1625
 1626%       prolog:called_by(+Goal, -Called)
 1627%
 1628%       Hook into library(pce_prolog_xref).  Called is a list of callable
 1629%       or callable+N to indicate (DCG) arglist extension.
 1630
 1631
 1632prolog:called_by(Goal, Called) :-
 1633    html_meta_head(Goal, _Module, Head),
 1634    html_meta_called(Head, Goal, Called).
 1635
 1636called_by(Term) -->
 1637    called_by(Term, _).
 1638
 1639called_by(Var, _) -->
 1640    { var(Var) },
 1641    !,
 1642    [].
 1643called_by(\G, M) -->
 1644    !,
 1645    (   { is_list(G) }
 1646    ->  called_by(G, M)
 1647    ;   {atom(M)}
 1648    ->  [(M:G)+2]
 1649    ;   [G+2]
 1650    ).
 1651called_by([], _) -->
 1652    !,
 1653    [].
 1654called_by([H|T], M) -->
 1655    !,
 1656    called_by(H, M),
 1657    called_by(T, M).
 1658called_by(M:Term, _) -->
 1659    !,
 1660    (   {atom(M)}
 1661    ->  called_by(Term, M)
 1662    ;   []
 1663    ).
 1664called_by(Term, M) -->
 1665    { compound(Term),
 1666      !,
 1667      Term =.. [_|Args]
 1668    },
 1669    called_by(Args, M).
 1670called_by(_, _) -->
 1671    [].
 1672
 1673:- multifile
 1674    prolog:hook/1. 1675
 1676prolog:hook(body(_,_,_)).
 1677prolog:hook(body(_,_,_,_)).
 1678prolog:hook(head(_,_,_)).
 1679prolog:hook(head(_,_,_,_)).
 1680
 1681
 1682                 /*******************************
 1683                 *            MESSAGES          *
 1684                 *******************************/
 1685
 1686:- multifile
 1687    prolog:message/3. 1688
 1689prolog:message(html(expand_failed(What))) -->
 1690    [ 'Failed to translate to HTML: ~p'-[What] ].
 1691prolog:message(html(wrong_encoding(Stream, Enc))) -->
 1692    [ 'XHTML demands UTF-8 encoding; encoding of ~p is ~w'-[Stream, Enc] ].
 1693prolog:message(html(multiple_receivers(Id))) -->
 1694    [ 'html_post//2: multiple receivers for: ~p'-[Id] ].
 1695prolog:message(html(no_receiver(Id))) -->
 1696    [ 'html_post//2: no receivers for: ~p'-[Id] ]