1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker and Anjo Anjewierden
    4    E-mail:        J.Wielemaker@vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2002-2020, University of Amsterdam
    7                              VU University Amsterdam
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   35
   36:- module(html_write,
   37          [ reply_html_page/2,          % :Head, :Body
   38            reply_html_page/3,          % +Style, :Head, :Body
   39
   40                                        % Basic output routines
   41            page//1,                    % :Content
   42            page//2,                    % :Head, :Body
   43            page//3,                    % +Style, :Head, :Body
   44            html//1,                    % :Content
   45
   46                                        % Option processing
   47            html_set_options/1,         % +OptionList
   48            html_current_option/1,      % ?Option
   49
   50                                        % repositioning HTML elements
   51            html_post//2,               % +Id, :Content
   52            html_receive//1,            % +Id
   53            html_receive//2,            % +Id, :Handler
   54            xhtml_ns//2,                % +Id, +Value
   55            html_root_attribute//2,     % +Name, +Value
   56
   57            html/4,                     % {|html||quasi quotations|}
   58
   59                                        % Useful primitives for expanding
   60            html_begin//1,              % +EnvName[(Attribute...)]
   61            html_end//1,                % +EnvName
   62            html_quoted//1,             % +Text
   63            html_quoted_attribute//1,   % +Attribute
   64
   65                                        % Emitting the HTML code
   66            print_html/1,               % +List
   67            print_html/2,               % +Stream, +List
   68            html_print_length/2,        % +List, -Length
   69
   70                                        % Extension support
   71            (html_meta)/1,              % +Spec
   72            op(1150, fx, html_meta)
   73          ]).   74:- use_module(html_quasiquotations, [html/4]).   75:- autoload(library(apply),[maplist/3,maplist/4]).   76:- autoload(library(debug),[debug/3]).   77:- autoload(library(error),
   78	    [must_be/2,domain_error/2,instantiation_error/1]).   79:- autoload(library(lists),
   80	    [permutation/2,selectchk/3,append/3,select/4,list_to_set/2]).   81:- autoload(library(option),[option/2]).   82:- autoload(library(pairs),[group_pairs_by_key/2]).   83:- autoload(library(sgml),[xml_quote_cdata/3,xml_quote_attribute/3]).   84:- autoload(library(uri),[uri_encoded/3]).   85:- autoload(library(url),[www_form_encode/2]).   86:- if(exists_source(library(http/http_dispatch))).   87:- autoload(library(http/http_dispatch), [http_location_by_id/2]).   88:- endif.   89
   90% Quote output
   91:- set_prolog_flag(generate_debug_info, false).   92
   93:- meta_predicate
   94    reply_html_page(+, :, :),
   95    reply_html_page(:, :),
   96    html(:, -, +),
   97    page(:, -, +),
   98    page(:, :, -, +),
   99    pagehead(+, :, -, +),
  100    pagebody(+, :, -, +),
  101    html_receive(+, 3, -, +),
  102    html_post(+, :, -, +).  103
  104:- multifile
  105    expand//1,                      % +HTMLElement
  106    expand_attribute_value//1,      % +HTMLAttributeValue
  107    html_header_hook/1.             % +Style

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

  144                 /*******************************
  145                 *            SETTINGS          *
  146                 *******************************/

 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.

  172html_set_options(Options) :-
  173    must_be(list, Options),
  174    set_options(Options).
  175
  176set_options([]).
  177set_options([H|T]) :-
  178    html_set_option(H),
  179    set_options(T).
  180
  181html_set_option(dialect(Dialect0)) :-
  182    !,
  183    must_be(oneof([html,html4,xhtml,html5]), Dialect0),
  184    (   html_version_alias(Dialect0, Dialect)
  185    ->  true
  186    ;   Dialect = Dialect0
  187    ),
  188    set_prolog_flag(html_dialect, Dialect).
  189html_set_option(doctype(Atom)) :-
  190    !,
  191    must_be(atom, Atom),
  192    current_prolog_flag(html_dialect, Dialect),
  193    dialect_doctype_flag(Dialect, Flag),
  194    set_prolog_flag(Flag, Atom).
  195html_set_option(content_type(Atom)) :-
  196    !,
  197    must_be(atom, Atom),
  198    current_prolog_flag(html_dialect, Dialect),
  199    dialect_content_type_flag(Dialect, Flag),
  200    set_prolog_flag(Flag, Atom).
  201html_set_option(O) :-
  202    domain_error(html_option, O).
  203
  204html_version_alias(html, html4).

 html_current_option(?Option) is nondet

True if Option is an active option for the HTML generator.

  210html_current_option(dialect(Dialect)) :-
  211    current_prolog_flag(html_dialect, Dialect).
  212html_current_option(doctype(DocType)) :-
  213    current_prolog_flag(html_dialect, Dialect),
  214    dialect_doctype_flag(Dialect, Flag),
  215    current_prolog_flag(Flag, DocType).
  216html_current_option(content_type(ContentType)) :-
  217    current_prolog_flag(html_dialect, Dialect),
  218    dialect_content_type_flag(Dialect, Flag),
  219    current_prolog_flag(Flag, ContentType).
  220
  221dialect_doctype_flag(html4, html4_doctype).
  222dialect_doctype_flag(html5, html5_doctype).
  223dialect_doctype_flag(xhtml, xhtml_doctype).
  224
  225dialect_content_type_flag(html4, html4_content_type).
  226dialect_content_type_flag(html5, html5_content_type).
  227dialect_content_type_flag(xhtml, xhtml_content_type).
  228
  229option_default(html_dialect, html5).
  230option_default(html4_doctype,
  231               'HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" \c
  232               "http://www.w3.org/TR/html4/loose.dtd"').
  233option_default(html5_doctype,
  234               'html').
  235option_default(xhtml_doctype,
  236               'html PUBLIC "-//W3C//DTD XHTML 1.0 \c
  237               Transitional//EN" \c
  238               "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"').
  239option_default(html4_content_type, 'text/html; charset=UTF-8').
  240option_default(html5_content_type, 'text/html; charset=UTF-8').
  241option_default(xhtml_content_type, 'application/xhtml+xml; charset=UTF-8').

 init_options is det

Initialise the HTML processing options.

  247init_options :-
  248    (   option_default(Name, Value),
  249        (   current_prolog_flag(Name, _)
  250        ->  true
  251        ;   create_prolog_flag(Name, Value, [])
  252        ),
  253        fail
  254    ;   true
  255    ).
  256
  257:- init_options.

 xml_header(-Header)

First line of XHTML document. Added by print_html/1.

  263xml_header('<?xml version=\'1.0\' encoding=\'UTF-8\'?>').

 ns(?Which, ?Atom)

Namespace declarations

  269ns(xhtml, 'http://www.w3.org/1999/xhtml').
  270
  271
  272                 /*******************************
  273                 *             PAGE             *
  274                 *******************************/

 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.

  283page(Content) -->
  284    doctype,
  285    html(html(Content)).
  286
  287page(Head, Body) -->
  288    page(default, Head, Body).
  289
  290page(Style, Head, Body) -->
  291    doctype,
  292    content_type,
  293    html_begin(html),
  294    pagehead(Style, Head),
  295    pagebody(Style, Body),
  296    html_end(html).

 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 ...

  305doctype -->
  306    { html_current_option(doctype(DocType)),
  307      DocType \== ''
  308    },
  309    !,
  310    [ '<!DOCTYPE ', DocType, '>' ].
  311doctype -->
  312    [].
  313
  314content_type -->
  315    { html_current_option(content_type(Type))
  316    },
  317    !,
  318    html_post(head, meta([ 'http-equiv'('content-type'),
  319                           content(Type)
  320                         ], [])).
  321content_type -->
  322    { html_current_option(dialect(html5)) },
  323    !,
  324    html_post(head, meta('charset=UTF-8')).
  325content_type -->
  326    [].
  327
  328pagehead(_, Head) -->
  329    { functor(Head, head, _)
  330    },
  331    !,
  332    html(Head).
  333pagehead(Style, Head) -->
  334    { strip_module(Head, M, _),
  335      hook_module(M, HM, head//2)
  336    },
  337    HM:head(Style, Head),
  338    !.
  339pagehead(_, Head) -->
  340    { strip_module(Head, M, _),
  341      hook_module(M, HM, head//1)
  342    },
  343    HM:head(Head),
  344    !.
  345pagehead(_, Head) -->
  346    html(head(Head)).
  347
  348
  349pagebody(_, Body) -->
  350    { functor(Body, body, _)
  351    },
  352    !,
  353    html(Body).
  354pagebody(Style, Body) -->
  355    { strip_module(Body, M, _),
  356      hook_module(M, HM, body//2)
  357    },
  358    HM:body(Style, Body),
  359    !.
  360pagebody(_, Body) -->
  361    { strip_module(Body, M, _),
  362      hook_module(M, HM, body//1)
  363    },
  364    HM:body(Body),
  365    !.
  366pagebody(_, Body) -->
  367    html(body(Body)).
  368
  369
  370hook_module(M, M, PI) :-
  371    current_predicate(M:PI),
  372    !.
  373hook_module(_, user, PI) :-
  374    current_predicate(user:PI).

 html(+Content:dom)// is det

Generate HTML from Content. Generates a token sequence for print_html/2.

  381html(Spec) -->
  382    { strip_module(Spec, M, T) },
  383    qhtml(T, M).
  384
  385qhtml(Var, _) -->
  386    { var(Var),
  387      !,
  388      instantiation_error(Var)
  389    }.
  390qhtml([], _) -->
  391    !,
  392    [].
  393qhtml([H|T], M) -->
  394    !,
  395    html_expand(H, M),
  396    qhtml(T, M).
  397qhtml(X, M) -->
  398    html_expand(X, M).
  399
  400html_expand(Var, _) -->
  401    { var(Var),
  402      !,
  403      instantiation_error(Var)
  404    }.
  405html_expand(Term, Module) -->
  406    do_expand(Term, Module),
  407    !.
  408html_expand(Term, _Module) -->
  409    { print_message(error, html(expand_failed(Term))) }.
  410
  411
  412do_expand(Token, _) -->                 % call user hooks
  413    expand(Token),
  414    !.
  415do_expand(Fmt-Args, _) -->
  416    !,
  417    { format(string(String), Fmt, Args)
  418    },
  419    html_quoted(String).
  420do_expand(\List, Module) -->
  421    { is_list(List)
  422    },
  423    !,
  424    raw(List, Module).
  425do_expand(\Term, Module, In, Rest) :-
  426    !,
  427    call(Module:Term, In, Rest).
  428do_expand(Module:Term, _) -->
  429    !,
  430    qhtml(Term, Module).
  431do_expand(&(Entity), _) -->
  432    !,
  433    {   integer(Entity)
  434    ->  format(string(String), '&#~d;', [Entity])
  435    ;   format(string(String), '&~w;', [Entity])
  436    },
  437    [ String ].
  438do_expand(Token, _) -->
  439    { atomic(Token)
  440    },
  441    !,
  442    html_quoted(Token).
  443do_expand(element(Env, Attributes, Contents), M) -->
  444    !,
  445    (   { Contents == [],
  446          html_current_option(dialect(xhtml))
  447        }
  448    ->  xhtml_empty(Env, Attributes)
  449    ;   html_begin(Env, Attributes),
  450        qhtml(Env, Contents, M),
  451        html_end(Env)
  452    ).
  453do_expand(Term, M) -->
  454    { Term =.. [Env, Contents]
  455    },
  456    !,
  457    (   { layout(Env, _, empty)
  458        }
  459    ->  html_begin(Env, Contents)
  460    ;   (   { Contents == [],
  461              html_current_option(dialect(xhtml))
  462            }
  463        ->  xhtml_empty(Env, [])
  464        ;   html_begin(Env),
  465            qhtml(Env, Contents, M),
  466            html_end(Env)
  467        )
  468    ).
  469do_expand(Term, M) -->
  470    { Term =.. [Env, Attributes, Contents],
  471      check_non_empty(Contents, Env, Term)
  472    },
  473    !,
  474    (   { Contents == [],
  475          html_current_option(dialect(xhtml))
  476        }
  477    ->  xhtml_empty(Env, Attributes)
  478    ;   html_begin(Env, Attributes),
  479        qhtml(Env, Contents, M),
  480        html_end(Env)
  481    ).
  482
  483qhtml(Env, Contents, M) -->
  484    { cdata_element(Env),
  485      phrase(cdata(Contents, M), Tokens)
  486    },
  487    !,
  488    [ cdata(Env, Tokens) ].
  489qhtml(_, Contents, M) -->
  490    qhtml(Contents, M).
  491
  492
  493check_non_empty([], _, _) :- !.
  494check_non_empty(_, Tag, Term) :-
  495    layout(Tag, _, empty),
  496    !,
  497    print_message(warning,
  498                  format('Using empty element with content: ~p', [Term])).
  499check_non_empty(_, _, _).
  500
  501cdata(List, M) -->
  502    { is_list(List) },
  503    !,
  504    raw(List, M).
  505cdata(One, M) -->
  506    raw_element(One, M).

 raw(+List, +Module)// is det

Emit unquoted (raw) output used for scripts, etc.

  512raw([], _) -->
  513    [].
  514raw([H|T], Module) -->
  515    raw_element(H, Module),
  516    raw(T, Module).
  517
  518raw_element(Var, _) -->
  519    { var(Var),
  520      !,
  521      instantiation_error(Var)
  522    }.
  523raw_element(\List, Module) -->
  524    { is_list(List)
  525    },
  526    !,
  527    raw(List, Module).
  528raw_element(\Term, Module, In, Rest) :-
  529    !,
  530    call(Module:Term, In, Rest).
  531raw_element(Module:Term, _) -->
  532    !,
  533    raw_element(Term, Module).
  534raw_element(Fmt-Args, _) -->
  535    !,
  536    { format(string(S), Fmt, Args) },
  537    [S].
  538raw_element(Value, _) -->
  539    { must_be(atomic, Value) },
  540    [Value].

 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)

  561html_begin(Env) -->
  562    { Env =.. [Name|Attributes]
  563    },
  564    html_begin(Name, Attributes).
  565
  566html_begin(Env, Attributes) -->
  567    pre_open(Env),
  568    [<],
  569    [Env],
  570    attributes(Env, Attributes),
  571    (   { layout(Env, _, empty),
  572          html_current_option(dialect(xhtml))
  573        }
  574    ->  ['/>']
  575    ;   [>]
  576    ),
  577    post_open(Env).
  578
  579html_end(Env)   -->                     % empty element or omited close
  580    { layout(Env, _, -),
  581      html_current_option(dialect(html))
  582    ; layout(Env, _, empty)
  583    },
  584    !,
  585    [].
  586html_end(Env)   -->
  587    pre_close(Env),
  588    ['</'],
  589    [Env],
  590    ['>'],
  591    post_close(Env).

 xhtml_empty(+Env, +Attributes)// is det

Emit element in xhtml mode with empty content.

  597xhtml_empty(Env, Attributes) -->
  598    pre_open(Env),
  599    [<],
  600    [Env],
  601    attributes(Attributes),
  602    ['/>'].

 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.

  627xhtml_ns(Id, Value) -->
  628    { html_current_option(dialect(xhtml)) },
  629    !,
  630    html_post(xmlns, \attribute(xmlns:Id=Value)).
  631xhtml_ns(_, _) -->
  632    [].

 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),
    ...

  645html_root_attribute(Name, Value) -->
  646    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.

  653attributes(html, L) -->
  654    !,
  655    (   { html_current_option(dialect(xhtml)) }
  656    ->  (   { option(xmlns(_), L) }
  657        ->  attributes(L)
  658        ;   { ns(xhtml, NS) },
  659            attributes([xmlns(NS)|L])
  660        ),
  661        html_receive(xmlns)
  662    ;   attributes(L),
  663        html_noreceive(xmlns)
  664    ),
  665    html_receive(html_begin).
  666attributes(_, L) -->
  667    attributes(L).
  668
  669attributes([]) -->
  670    !,
  671    [].
  672attributes([H|T]) -->
  673    !,
  674    attribute(H),
  675    attributes(T).
  676attributes(One) -->
  677    attribute(One).
  678
  679attribute(Name=Value) -->
  680    !,
  681    [' '], name(Name), [ '="' ],
  682    attribute_value(Value),
  683    ['"'].
  684attribute(NS:Term) -->
  685    !,
  686    { Term =.. [Name, Value]
  687    },
  688    !,
  689    attribute((NS:Name)=Value).
  690attribute(Term) -->
  691    { Term =.. [Name, Value]
  692    },
  693    !,
  694    attribute(Name=Value).
  695attribute(Atom) -->                     % Value-abbreviated attribute
  696    { atom(Atom)
  697    },
  698    [ ' ', Atom ].
  699
  700name(NS:Name) -->
  701    !,
  702    [NS, :, Name].
  703name(Name) -->
  704    [ Name ].

 attribute_value(+Value) is det

Print an attribute value. Value is either atomic or one of the following terms:

• A+B Concatenation of A and B
• encode(V) Emit URL-encoded version of V. See www_form_encode/2.
• An option list Emit ?Name1=encode(Value1)&Name2=encode(Value2) ...
• A term Format-Arguments Use format/3 and emit the result as quoted value.

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.

  726attribute_value(List) -->
  727    { is_list(List) },
  728    !,
  729    attribute_value_m(List).
  730attribute_value(Value) -->
  731    attribute_value_s(Value).
  732
  733% emit a single attribute value
  734
  735attribute_value_s(Var) -->
  736    { var(Var),
  737      !,
  738      instantiation_error(Var)
  739    }.
  740attribute_value_s(A+B) -->
  741    !,
  742    attribute_value(A),
  743    (   { is_list(B) }
  744    ->  (   { B == [] }
  745        ->  []
  746        ;   [?], search_parameters(B)
  747        )
  748    ;   attribute_value(B)
  749    ).
  750attribute_value_s(encode(Value)) -->
  751    !,
  752    { uri_encoded(query_value, Value, Encoded) },
  753    [ Encoded ].
  754attribute_value_s(Value) -->
  755    expand_attribute_value(Value),
  756    !.
  757attribute_value_s(Fmt-Args) -->
  758    !,
  759    { format(string(Value), Fmt, Args) },
  760    html_quoted_attribute(Value).
  761attribute_value_s(Value) -->
  762    html_quoted_attribute(Value).
  763
  764search_parameters([H|T]) -->
  765    search_parameter(H),
  766    (   {T == []}
  767    ->  []
  768    ;   ['&'],
  769        search_parameters(T)
  770    ).
  771
  772search_parameter(Var) -->
  773    { var(Var),
  774      !,
  775      instantiation_error(Var)
  776    }.
  777search_parameter(Name=Value) -->
  778    { www_form_encode(Value, Encoded) },
  779    [Name, =, Encoded].
  780search_parameter(Term) -->
  781    { Term =.. [Name, Value],
  782      !,
  783      www_form_encode(Value, Encoded)
  784    },
  785    [Name, =, Encoded].
  786search_parameter(Term) -->
  787    { domain_error(search_parameter, Term)
  788    }.

 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"> ...

  800attribute_value_m([]) -->
  801    [].
  802attribute_value_m([H|T]) -->
  803    attribute_value_s(H),
  804    (   { T == [] }
  805    ->  []
  806    ;   [' '],
  807        attribute_value_m(T)
  808    ).
  809
  810
  811                 /*******************************
  812                 *         QUOTING RULES        *
  813                 *******************************/

 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.

  828html_quoted(Text) -->
  829    { xml_quote_cdata(Text, Quoted, utf8) },
  830    [ 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.

  841html_quoted_attribute(Text) -->
  842    { xml_quote_attribute(Text, Quoted, utf8) },
  843    [ Quoted ].

 cdata_element(?Element)

True when Element contains declared CDATA and thus only </ needs to be escaped.

  850cdata_element(script).
  851cdata_element(style).
  852
  853
  854                 /*******************************
  855                 *      REPOSITIONING HTML      *
  856                 *******************************/

 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)
                        ],
                        ...)

  888html_post(Id, Content) -->
  889    { strip_module(Content, M, C) },
  890    [ 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.

  903html_receive(Id) -->
  904    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.

  923html_receive(Id, Handler) -->
  924    { strip_module(Handler, M, P) },
  925    [ mailbox(Id, accept(M:P, _)) ].

 html_noreceive(+Id)// is det

As html_receive//1, but discard posted messages.

  931html_noreceive(Id) -->
  932    [ 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.

  943mailman(Tokens) :-
  944    (   html_token(mailbox(_, accept(_, Accepted)), Tokens)
  945    ->  true
  946    ),
  947    var(Accepted),                 % not yet executed
  948    !,
  949    mailboxes(Tokens, Boxes),
  950    keysort(Boxes, Keyed),
  951    group_pairs_by_key(Keyed, PerKey),
  952    move_last(PerKey, script, PerKey1),
  953    move_last(PerKey1, head, PerKey2),
  954    (   permutation(PerKey2, PerKeyPerm),
  955        (   mail_ids(PerKeyPerm)
  956        ->  !
  957        ;   debug(html(mailman),
  958                  'Failed mail delivery order; retrying', []),
  959            fail
  960        )
  961    ->  true
  962    ;   print_message(error, html(cyclic_mailboxes))
  963    ).
  964mailman(_).
  965
  966move_last(Box0, Id, Box) :-
  967    selectchk(Id-List, Box0, Box1),
  968    !,
  969    append(Box1, [Id-List], Box).
  970move_last(Box, _, Box).

 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).

  977html_token(Token, [H|T]) :-
  978    html_token_(T, H, Token).
  979
  980html_token_(_, Token, Token) :- !.
  981html_token_(_, cdata(_,Tokens), Token) :-
  982    html_token(Token, Tokens).
  983html_token_([H|T], _, Token) :-
  984    html_token_(T, H, Token).

 mailboxes(+Tokens, -MailBoxes) is det

Get all mailboxes from the token set.

  990mailboxes(Tokens, MailBoxes) :-
  991    mailboxes(Tokens, MailBoxes, []).
  992
  993mailboxes([], List, List).
  994mailboxes([mailbox(Id, Value)|T0], [Id-Value|T], Tail) :-
  995    !,
  996    mailboxes(T0, T, Tail).
  997mailboxes([cdata(_Type, Tokens)|T0], Boxes, Tail) :-
  998    !,
  999    mailboxes(Tokens, Boxes, Tail0),
 1000    mailboxes(T0, Tail0, Tail).
 1001mailboxes([_|T0], T, Tail) :-
 1002    mailboxes(T0, T, Tail).
 1003
 1004mail_ids([]).
 1005mail_ids([H|T0]) :-
 1006    mail_id(H, NewPosts),
 1007    add_new_posts(NewPosts, T0, T),
 1008    mail_ids(T).
 1009
 1010mail_id(Id-List, NewPosts) :-
 1011    mail_handlers(List, Boxes, Content),
 1012    (   Boxes = [accept(MH:Handler, In)]
 1013    ->  extend_args(Handler, Content, Goal),
 1014        phrase(MH:Goal, In),
 1015        mailboxes(In, NewBoxes),
 1016        keysort(NewBoxes, Keyed),
 1017        group_pairs_by_key(Keyed, NewPosts)
 1018    ;   Boxes = [ignore(_, _)|_]
 1019    ->  NewPosts = []
 1020    ;   Boxes = [accept(_,_),accept(_,_)|_]
 1021    ->  print_message(error, html(multiple_receivers(Id))),
 1022        NewPosts = []
 1023    ;   print_message(error, html(no_receiver(Id))),
 1024        NewPosts = []
 1025    ).
 1026
 1027add_new_posts([], T, T).
 1028add_new_posts([Id-Posts|NewT], T0, T) :-
 1029    (   select(Id-List0, T0, Id-List, T1)
 1030    ->  append(List0, Posts, List)
 1031    ;   debug(html(mailman), 'Stuck with new posts on ~q', [Id]),
 1032        fail
 1033    ),
 1034    add_new_posts(NewT, T1, T).

 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(_,_).

 1043mail_handlers([], [], []).
 1044mail_handlers([post(Module,HTML)|T0], H, [Module:HTML|T]) :-
 1045    !,
 1046    mail_handlers(T0, H, T).
 1047mail_handlers([H|T0], [H|T], C) :-
 1048    mail_handlers(T0, T, C).
 1049
 1050extend_args(Term, Extra, NewTerm) :-
 1051    Term =.. [Name|Args],
 1052    append(Args, [Extra], NewArgs),
 1053    NewTerm =.. [Name|NewArgs].

 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?

 1064sorted_html(List) -->
 1065    { sort(List, Unique) },
 1066    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.

 1079head_html(List) -->
 1080    { list_to_set(List, Unique),
 1081      html_expand_head(Unique, NewList)
 1082    },
 1083    html(NewList).
 1084
 1085:- multifile
 1086    html_head_expansion/2. 1087
 1088html_expand_head(List0, List) :-
 1089    html_head_expansion(List0, List1),
 1090    List0 \== List1,
 1091    !,
 1092    html_expand_head(List1, List).
 1093html_expand_head(List, List).
 1094
 1095
 1096                 /*******************************
 1097                 *             LAYOUT           *
 1098                 *******************************/
 1099
 1100pre_open(Env) -->
 1101    { layout(Env, N-_, _)
 1102    },
 1103    !,
 1104    [ nl(N) ].
 1105pre_open(_) --> [].
 1106
 1107post_open(Env) -->
 1108    { layout(Env, _-N, _)
 1109    },
 1110    !,
 1111    [ nl(N) ].
 1112post_open(_) -->
 1113    [].
 1114
 1115pre_close(head) -->
 1116    !,
 1117    html_receive(head, head_html),
 1118    { layout(head, _, N-_) },
 1119    [ nl(N) ].
 1120pre_close(Env) -->
 1121    { layout(Env, _, N-_)
 1122    },
 1123    !,
 1124    [ nl(N) ].
 1125pre_close(_) -->
 1126    [].
 1127
 1128post_close(Env) -->
 1129    { layout(Env, _, _-N)
 1130    },
 1131    !,
 1132    [ nl(N) ].
 1133post_close(_) -->
 1134    [].

 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

 1151:- multifile
 1152    layout/3. 1153
 1154layout(table,      2-1, 1-2).
 1155layout(blockquote, 2-1, 1-2).
 1156layout(pre,        2-1, 0-2).
 1157layout(textarea,   1-1, 0-1).
 1158layout(center,     2-1, 1-2).
 1159layout(dl,         2-1, 1-2).
 1160layout(ul,         1-1, 1-1).
 1161layout(ol,         2-1, 1-2).
 1162layout(form,       2-1, 1-2).
 1163layout(frameset,   2-1, 1-2).
 1164layout(address,    2-1, 1-2).
 1165
 1166layout(head,       1-1, 1-1).
 1167layout(body,       1-1, 1-1).
 1168layout(script,     1-1, 1-1).
 1169layout(style,      1-1, 1-1).
 1170layout(select,     1-1, 1-1).
 1171layout(map,        1-1, 1-1).
 1172layout(html,       1-1, 1-1).
 1173layout(caption,    1-1, 1-1).
 1174layout(applet,     1-1, 1-1).
 1175
 1176layout(tr,         1-0, 0-1).
 1177layout(option,     1-0, 0-1).
 1178layout(li,         1-0, 0-1).
 1179layout(dt,         1-0, -).
 1180layout(dd,         0-0, -).
 1181layout(title,      1-0, 0-1).
 1182
 1183layout(h1,         2-0, 0-2).
 1184layout(h2,         2-0, 0-2).
 1185layout(h3,         2-0, 0-2).
 1186layout(h4,         2-0, 0-2).
 1187
 1188layout(iframe,     1-1, 1-1).
 1189
 1190layout(hr,         1-1, empty).         % empty elements
 1191layout(br,         0-1, empty).
 1192layout(img,        0-0, empty).
 1193layout(meta,       1-1, empty).
 1194layout(base,       1-1, empty).
 1195layout(link,       1-1, empty).
 1196layout(input,      0-0, empty).
 1197layout(frame,      1-1, empty).
 1198layout(col,        0-0, empty).
 1199layout(area,       1-0, empty).
 1200layout(input,      1-0, empty).
 1201layout(param,      1-0, empty).
 1202
 1203layout(p,          2-1, -).             % omited close
 1204layout(td,         0-0, 0-0).
 1205
 1206layout(div,        1-0, 0-1).
 1207
 1208                 /*******************************
 1209                 *           PRINTING           *
 1210                 *******************************/

 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)

 1225print_html(List) :-
 1226    current_output(Out),
 1227    mailman(List),
 1228    write_html(List, Out).
 1229print_html(Out, List) :-
 1230    (   html_current_option(dialect(xhtml))
 1231    ->  stream_property(Out, encoding(Enc)),
 1232        (   Enc == utf8
 1233        ->  true
 1234        ;   print_message(warning, html(wrong_encoding(Out, Enc)))
 1235        ),
 1236        xml_header(Hdr),
 1237        write(Out, Hdr), nl(Out)
 1238    ;   true
 1239    ),
 1240    mailman(List),
 1241    write_html(List, Out),
 1242    flush_output(Out).
 1243
 1244write_html([], _).
 1245write_html([nl(N)|T], Out) :-
 1246    !,
 1247    join_nl(T, N, Lines, T2),
 1248    write_nl(Lines, Out),
 1249    write_html(T2, Out).
 1250write_html([mailbox(_, Box)|T], Out) :-
 1251    !,
 1252    (   Box = accept(_, Accepted)
 1253    ->  write_html(Accepted, Out)
 1254    ;   true
 1255    ),
 1256    write_html(T, Out).
 1257write_html([cdata(Env, Tokens)|T], Out) :-
 1258    !,
 1259    with_output_to(string(CDATA), write_html(Tokens, current_output)),
 1260    valid_cdata(Env, CDATA),
 1261    write(Out, CDATA),
 1262    write_html(T, Out).
 1263write_html([H|T], Out) :-
 1264    write(Out, H),
 1265    write_html(T, Out).
 1266
 1267join_nl([nl(N0)|T0], N1, N, T) :-
 1268    !,
 1269    N2 is max(N0, N1),
 1270    join_nl(T0, N2, N, T).
 1271join_nl(L, N, N, L).
 1272
 1273write_nl(0, _) :- !.
 1274write_nl(N, Out) :-
 1275    nl(Out),
 1276    N1 is N - 1,
 1277    write_nl(N1, Out).

 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.

 1291valid_cdata(Env, String) :-
 1292    atomics_to_string(['</', Env, '>'], End),
 1293    sub_atom_icasechk(String, _, End),
 1294    !,
 1295    domain_error(cdata, String).
 1296valid_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)

 1312html_print_length(List, Len) :-
 1313    mailman(List),
 1314    (   html_current_option(dialect(xhtml))
 1315    ->  xml_header(Hdr),
 1316        atom_length(Hdr, L0),
 1317        L1 is L0+1                  % one for newline
 1318    ;   L1 = 0
 1319    ),
 1320    html_print_length(List, L1, Len).
 1321
 1322html_print_length([], L, L).
 1323html_print_length([nl(N)|T], L0, L) :-
 1324    !,
 1325    join_nl(T, N, Lines, T1),
 1326    L1 is L0 + Lines,               % assume only \n!
 1327    html_print_length(T1, L1, L).
 1328html_print_length([mailbox(_, Box)|T], L0, L) :-
 1329    !,
 1330    (   Box = accept(_, Accepted)
 1331    ->  html_print_length(Accepted, L0, L1)
 1332    ;   L1 = L0
 1333    ),
 1334    html_print_length(T, L1, L).
 1335html_print_length([cdata(_, CDATA)|T], L0, L) :-
 1336    !,
 1337    html_print_length(CDATA, L0, L1),
 1338    html_print_length(T, L1, L).
 1339html_print_length([H|T], L0, L) :-
 1340    atom_length(H, Hlen),
 1341    L1 is L0+Hlen,
 1342    html_print_length(T, L1, L).

 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.

 1352reply_html_page(Head, Body) :-
 1353    reply_html_page(default, Head, Body).
 1354reply_html_page(Style, Head, Body) :-
 1355    html_current_option(content_type(Type)),
 1356    phrase(page(Style, Head, Body), HTML),
 1357    forall(html_header_hook(Style), true),
 1358    format('Content-type: ~w~n~n', [Type]),
 1359    print_html(HTML).

 html_header_hook(+Style) is nondet

This multifile hook is called just before the Content-type header is emitted. It allows for emitting additional headers depending on the first argument of reply_html_page/3.

 1370                 /*******************************
 1371                 *     META-PREDICATE SUPPORT   *
 1372                 *******************************/

 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,?,?).

 1388html_meta(Spec) :-
 1389    throw(error(context_error(nodirective, html_meta(Spec)), _)).
 1390
 1391html_meta_decls(Var, _, _) :-
 1392    var(Var),
 1393    !,
 1394    instantiation_error(Var).
 1395html_meta_decls((A,B), (MA,MB), [MH|T]) :-
 1396    !,
 1397    html_meta_decl(A, MA, MH),
 1398    html_meta_decls(B, MB, T).
 1399html_meta_decls(A, MA, [MH]) :-
 1400    html_meta_decl(A, MA, MH).
 1401
 1402html_meta_decl(Head, MetaHead,
 1403               html_write:html_meta_head(GenHead, Module, Head)) :-
 1404    functor(Head, Name, Arity),
 1405    functor(GenHead, Name, Arity),
 1406    prolog_load_context(module, Module),
 1407    Head =.. [Name|HArgs],
 1408    maplist(html_meta_decl, HArgs, MArgs),
 1409    MetaHead =.. [Name|MArgs].
 1410
 1411html_meta_decl(html, :) :- !.
 1412html_meta_decl(Meta, Meta).
 1413
 1414system:term_expansion((:- html_meta(Heads)),
 1415                      [ (:- meta_predicate(Meta))
 1416                      | MetaHeads
 1417                      ]) :-
 1418    html_meta_decls(Heads, Meta, MetaHeads).
 1419
 1420:- multifile
 1421    html_meta_head/3. 1422
 1423html_meta_colours(Head, Goal, built_in-Colours) :-
 1424    Head =.. [_|MArgs],
 1425    Goal =.. [_|Args],
 1426    maplist(meta_colours, MArgs, Args, Colours).
 1427
 1428meta_colours(html, HTML, Colours) :-
 1429    !,
 1430    html_colours(HTML, Colours).
 1431meta_colours(I, _, Colours) :-
 1432    integer(I), I>=0,
 1433    !,
 1434    Colours = meta(I).
 1435meta_colours(_, _, classify).
 1436
 1437html_meta_called(Head, Goal, Called) :-
 1438    Head =.. [_|MArgs],
 1439    Goal =.. [_|Args],
 1440    meta_called(MArgs, Args, Called, []).
 1441
 1442meta_called([], [], Called, Called).
 1443meta_called([html|MT], [A|AT], Called, Tail) :-
 1444    !,
 1445    phrase(called_by(A), Called, Tail1),
 1446    meta_called(MT, AT, Tail1, Tail).
 1447meta_called([0|MT], [A|AT], [A|CT0], CT) :-
 1448    !,
 1449    meta_called(MT, AT, CT0, CT).
 1450meta_called([I|MT], [A|AT], [A+I|CT0], CT) :-
 1451    integer(I), I>0,
 1452    !,
 1453    meta_called(MT, AT, CT0, CT).
 1454meta_called([_|MT], [_|AT], Called, Tail) :-
 1455    !,
 1456    meta_called(MT, AT, Called, Tail).
 1457
 1458
 1459:- html_meta
 1460    html(html,?,?),
 1461    page(html,?,?),
 1462    page(html,html,?,?),
 1463    page(+,html,html,?,?),
 1464    pagehead(+,html,?,?),
 1465    pagebody(+,html,?,?),
 1466    reply_html_page(html,html),
 1467    reply_html_page(+,html,html),
 1468    html_post(+,html,?,?). 1469
 1470
 1471                 /*******************************
 1472                 *      PCE EMACS SUPPORT       *
 1473                 *******************************/
 1474
 1475:- multifile
 1476    prolog_colour:goal_colours/2,
 1477    prolog_colour:style/2,
 1478    prolog_colour:message//1,
 1479    prolog:called_by/2. 1480
 1481prolog_colour:goal_colours(Goal, Colours) :-
 1482    html_meta_head(Goal, _Module, Head),
 1483    html_meta_colours(Head, Goal, Colours).
 1484prolog_colour:goal_colours(html_meta(_),
 1485                           built_in-[meta_declarations([html])]).
 1486
 1487                                        % TBD: Check with do_expand!
 1488html_colours(Var, classify) :-
 1489    var(Var),
 1490    !.
 1491html_colours(\List, html_raw-[list-Colours]) :-
 1492    is_list(List),
 1493    !,
 1494    list_colours(List, Colours).
 1495html_colours(\_, html_call-[dcg]) :- !.
 1496html_colours(_:Term, built_in-[classify,Colours]) :-
 1497    !,
 1498    html_colours(Term, Colours).
 1499html_colours(&(Entity), functor-[entity(Entity)]) :- !.
 1500html_colours(List, list-ListColours) :-
 1501    List = [_|_],
 1502    !,
 1503    list_colours(List, ListColours).
 1504html_colours(Format-Args, functor-[FormatColor,ArgsColors]) :-
 1505    !,
 1506    format_colours(Format, FormatColor),
 1507    format_arg_colours(Args, Format, ArgsColors).
 1508html_colours(Term, TermColours) :-
 1509    compound(Term),
 1510    compound_name_arguments(Term, Name, Args),
 1511    Name \== '.',
 1512    !,
 1513    (   Args = [One]
 1514    ->  TermColours = html(Name)-ArgColours,
 1515        (   layout(Name, _, empty)
 1516        ->  attr_colours(One, ArgColours)
 1517        ;   html_colours(One, Colours),
 1518            ArgColours = [Colours]
 1519        )
 1520    ;   Args = [AList,Content]
 1521    ->  TermColours = html(Name)-[AColours, Colours],
 1522        attr_colours(AList, AColours),
 1523        html_colours(Content, Colours)
 1524    ;   TermColours = error
 1525    ).
 1526html_colours(_, classify).
 1527
 1528list_colours(Var, classify) :-
 1529    var(Var),
 1530    !.
 1531list_colours([], []).
 1532list_colours([H0|T0], [H|T]) :-
 1533    !,
 1534    html_colours(H0, H),
 1535    list_colours(T0, T).
 1536list_colours(Last, Colours) :-          % improper list
 1537    html_colours(Last, Colours).
 1538
 1539attr_colours(Var, classify) :-
 1540    var(Var),
 1541    !.
 1542attr_colours([], classify) :- !.
 1543attr_colours(Term, list-Elements) :-
 1544    Term = [_|_],
 1545    !,
 1546    attr_list_colours(Term, Elements).
 1547attr_colours(Name=Value, built_in-[html_attribute(Name), VColour]) :-
 1548    !,
 1549    attr_value_colour(Value, VColour).
 1550attr_colours(NS:Term, built_in-[ html_xmlns(NS),
 1551                                 html_attribute(Name)-[classify]
 1552                               ]) :-
 1553    compound(Term),
 1554    compound_name_arity(Term, Name, 1).
 1555attr_colours(Term, html_attribute(Name)-[VColour]) :-
 1556    compound(Term),
 1557    compound_name_arity(Term, Name, 1),
 1558    !,
 1559    Term =.. [Name,Value],
 1560    attr_value_colour(Value, VColour).
 1561attr_colours(Name, html_attribute(Name)) :-
 1562    atom(Name),
 1563    !.
 1564attr_colours(Term, classify) :-
 1565    compound(Term),
 1566    compound_name_arity(Term, '.', 2),
 1567    !.
 1568attr_colours(_, error).
 1569
 1570attr_list_colours(Var, classify) :-
 1571    var(Var),
 1572    !.
 1573attr_list_colours([], []).
 1574attr_list_colours([H0|T0], [H|T]) :-
 1575    attr_colours(H0, H),
 1576    attr_list_colours(T0, T).
 1577
 1578attr_value_colour(Var, classify) :-
 1579    var(Var).
 1580attr_value_colour(location_by_id(ID), sgml_attr_function-[Colour]) :-
 1581    !,
 1582    location_id(ID, Colour).
 1583attr_value_colour(#(ID), sgml_attr_function-[Colour]) :-
 1584    !,
 1585    location_id(ID, Colour).
 1586attr_value_colour(A+B, sgml_attr_function-[CA,CB]) :-
 1587    !,
 1588    attr_value_colour(A, CA),
 1589    attr_value_colour(B, CB).
 1590attr_value_colour(encode(_), sgml_attr_function-[classify]) :- !.
 1591attr_value_colour(Atom, classify) :-
 1592    atomic(Atom),
 1593    !.
 1594attr_value_colour([_|_], classify) :- !.
 1595attr_value_colour(_Fmt-_Args, classify) :- !.
 1596attr_value_colour(Term, classify) :-
 1597    compound(Term),
 1598    compound_name_arity(Term, '.', 2),
 1599    !.
 1600attr_value_colour(_, error).
 1601
 1602location_id(ID, classify) :-
 1603    var(ID),
 1604    !.
 1605:- if(current_predicate(http_location_for_id/1)). 1606location_id(ID, Class) :-
 1607    (   catch(http_location_by_id(ID, Location), _, fail)
 1608    ->  Class = http_location_for_id(Location)
 1609    ;   Class = http_no_location_for_id(ID)
 1610    ).
 1611:- endif. 1612location_id(_, classify).
 1613
 1614format_colours(Format, format_string) :- atom(Format), !.
 1615format_colours(Format, format_string) :- string(Format), !.
 1616format_colours(_Format, type_error(text)).
 1617
 1618format_arg_colours(Args, _Format, classify) :- is_list(Args), !.
 1619format_arg_colours(_, _, type_error(list)).
 1620
 1621:- op(990, xfx, :=).                    % allow compiling without XPCE
 1622:- op(200, fy, @). 1623
 1624prolog_colour:style(html(_),                    [colour(magenta4), bold(true)]).
 1625prolog_colour:style(entity(_),                  [colour(magenta4)]).
 1626prolog_colour:style(html_attribute(_),          [colour(magenta4)]).
 1627prolog_colour:style(html_xmlns(_),              [colour(magenta4)]).
 1628prolog_colour:style(format_string(_),           [colour(magenta4)]).
 1629prolog_colour:style(sgml_attr_function,         [colour(blue)]).
 1630prolog_colour:style(http_location_for_id(_),    [bold(true)]).
 1631prolog_colour:style(http_no_location_for_id(_), [colour(red), bold(true)]).
 1632
 1633
 1634prolog_colour:message(html(Element)) -->
 1635    [ '~w: SGML element'-[Element] ].
 1636prolog_colour:message(entity(Entity)) -->
 1637    [ '~w: SGML entity'-[Entity] ].
 1638prolog_colour:message(html_attribute(Attr)) -->
 1639    [ '~w: SGML attribute'-[Attr] ].
 1640prolog_colour:message(sgml_attr_function) -->
 1641    [ 'SGML Attribute function'-[] ].
 1642prolog_colour:message(http_location_for_id(Location)) -->
 1643    [ 'ID resolves to ~w'-[Location] ].
 1644prolog_colour:message(http_no_location_for_id(ID)) -->
 1645    [ '~w: no such ID'-[ID] ].
 1646
 1647
 1648%       prolog:called_by(+Goal, -Called)
 1649%
 1650%       Hook into library(pce_prolog_xref).  Called is a list of callable
 1651%       or callable+N to indicate (DCG) arglist extension.
 1652
 1653
 1654prolog:called_by(Goal, Called) :-
 1655    html_meta_head(Goal, _Module, Head),
 1656    html_meta_called(Head, Goal, Called).
 1657
 1658called_by(Term) -->
 1659    called_by(Term, _).
 1660
 1661called_by(Var, _) -->
 1662    { var(Var) },
 1663    !,
 1664    [].
 1665called_by(\G, M) -->
 1666    !,
 1667    (   { is_list(G) }
 1668    ->  called_by(G, M)
 1669    ;   {atom(M)}
 1670    ->  [(M:G)+2]
 1671    ;   [G+2]
 1672    ).
 1673called_by([], _) -->
 1674    !,
 1675    [].
 1676called_by([H|T], M) -->
 1677    !,
 1678    called_by(H, M),
 1679    called_by(T, M).
 1680called_by(M:Term, _) -->
 1681    !,
 1682    (   {atom(M)}
 1683    ->  called_by(Term, M)
 1684    ;   []
 1685    ).
 1686called_by(Term, M) -->
 1687    { compound(Term),
 1688      !,
 1689      Term =.. [_|Args]
 1690    },
 1691    called_by(Args, M).
 1692called_by(_, _) -->
 1693    [].
 1694
 1695:- multifile
 1696    prolog:hook/1. 1697
 1698prolog:hook(body(_,_,_)).
 1699prolog:hook(body(_,_,_,_)).
 1700prolog:hook(head(_,_,_)).
 1701prolog:hook(head(_,_,_,_)).
 1702
 1703
 1704                 /*******************************
 1705                 *            MESSAGES          *
 1706                 *******************************/
 1707
 1708:- multifile
 1709    prolog:message/3. 1710
 1711prolog:message(html(expand_failed(What))) -->
 1712    [ 'Failed to translate to HTML: ~p'-[What] ].
 1713prolog:message(html(wrong_encoding(Stream, Enc))) -->
 1714    [ 'XHTML demands UTF-8 encoding; encoding of ~p is ~w'-[Stream, Enc] ].
 1715prolog:message(html(multiple_receivers(Id))) -->
 1716    [ 'html_post//2: multiple receivers for: ~p'-[Id] ].
 1717prolog:message(html(no_receiver(Id))) -->
 1718    [ 'html_post//2: no receivers for: ~p'-[Id] ]