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        nonvar(Accepted)
 1254    ->  write_html(Accepted, Out)
 1255    ;   true
 1256    ),
 1257    write_html(T, Out).
 1258write_html([cdata(Env, Tokens)|T], Out) :-
 1259    !,
 1260    with_output_to(string(CDATA), write_html(Tokens, current_output)),
 1261    valid_cdata(Env, CDATA),
 1262    write(Out, CDATA),
 1263    write_html(T, Out).
 1264write_html([H|T], Out) :-
 1265    write(Out, H),
 1266    write_html(T, Out).
 1267
 1268join_nl([nl(N0)|T0], N1, N, T) :-
 1269    !,
 1270    N2 is max(N0, N1),
 1271    join_nl(T0, N2, N, T).
 1272join_nl(L, N, N, L).
 1273
 1274write_nl(0, _) :- !.
 1275write_nl(N, Out) :-
 1276    nl(Out),
 1277    N1 is N - 1,
 1278    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.

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

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

 1353reply_html_page(Head, Body) :-
 1354    reply_html_page(default, Head, Body).
 1355reply_html_page(Style, Head, Body) :-
 1356    html_current_option(content_type(Type)),
 1357    phrase(page(Style, Head, Body), HTML),
 1358    forall(html_header_hook(Style), true),
 1359    format('Content-type: ~w~n~n', [Type]),
 1360    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.

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

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

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