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:- use_module(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(area,       1-0, empty).
 1191layout(base,       1-1, empty).
 1192layout(br,         0-1, empty).
 1193layout(col,        0-0, empty).
 1194layout(embed,      1-1, empty).
 1195layout(hr,         1-1, empty).         % empty elements
 1196layout(img,        0-0, empty).
 1197layout(input,      1-0, empty).
 1198layout(link,       1-1, empty).
 1199layout(meta,       1-1, empty).
 1200layout(param,      1-0, empty).
 1201layout(source,     1-0, empty).
 1202layout(track,	   1-0, empty).
 1203layout(wbr,	   0-0, empty).
 1204
 1205layout(p,          2-1, -).             % omited close
 1206layout(td,         0-0, 0-0).
 1207
 1208layout(div,        1-0, 0-1).
 1209
 1210                 /*******************************
 1211                 *           PRINTING           *
 1212                 *******************************/

 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)

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

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

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

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

 1373                 /*******************************
 1374                 *     META-PREDICATE SUPPORT   *
 1375                 *******************************/

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

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