1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2014, VU University Amsterdam
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(term_html,
   36          [ term//2                             % +Term, +Options
   37          ]).   38:- use_module(library(http/html_write)).   39:- use_module(library(option)).   40:- use_module(library(error)).   41:- use_module(library(debug)).   42
   43:- multifile
   44    blob_rendering//3,              % +Type, +Blob, +Options
   45    portray//2.                     % +Term, +Options

 term(@Term, +Options)// is det

Render a Prolog term as a structured HTML tree. Options are passed to write_term/3. In addition, the following options are processed:

format(+Format)

Used for atomic values. Typically this is used to render a single value.

float_format(+Format)

If a float is rendered, it is rendered using format(string(S), Format, [Float])

To be done

- Cyclic terms.

- Attributed terms.

- Portray

- Test with Ulrich's write test set.

- Deal with numbervars and canonical.

   73term(Term, Options) -->
   74    { must_be(acyclic, Term),
   75      merge_options(Options,
   76                    [ priority(1200),
   77                      max_depth(1 000 000 000),
   78                      depth(0)
   79                    ],
   80                    Options1),
   81      dict_options(Dict, Options1)
   82    },
   83    any(Term, Dict).
   84
   85
   86any(_, Options) -->
   87    { Options.depth >= Options.max_depth },
   88    !,
   89    html(span(class('pl-ellipsis'), ...)).
   90any(Term, Options) -->
   91    (   {   nonvar(Term)
   92        ;   attvar(Term)
   93        }
   94    ->  portray(Term, Options)
   95    ),
   96    !.
   97any(Term, Options) -->
   98    { primitive(Term, Class0),
   99      !,
  100      quote_atomic(Term, S, Options),
  101      primitive_class(Class0, Term, S, Class)
  102    },
  103    html(span(class(Class), S)).
  104any(Term, Options) -->
  105    { blob(Term,Type), Term \== [] },
  106    !,
  107    (   blob_rendering(Type,Term,Options)
  108    ->  []
  109    ;   html(span(class('pl-blob'),['<',Type,'>']))
  110    ).
  111any(Term, Options) -->
  112    { is_dict(Term), !
  113    },
  114    dict(Term, Options).
  115any(Term, Options) -->
  116    { assertion((compound(Term);Term==[]))
  117    },
  118    compound(Term, Options).

 compound(+Compound, +Options)// is det

Process a compound term.

  124compound('$VAR'(Var), Options) -->
  125    { Options.get(numbervars) == true,
  126      !,
  127      format(string(S), '~W', ['$VAR'(Var), [numbervars(true)]]),
  128      (   S == "_"
  129      ->  Class = 'pl-anon'
  130      ;   Class = 'pl-var'
  131      )
  132    },
  133    html(span(class(Class), S)).
  134compound(List, Options) -->
  135    { (   List == []
  136      ;   List = [_|_]                              % May have unbound tail
  137      ),
  138      !,
  139      arg_options(Options, _{priority:999}, ArgOptions)
  140    },
  141    list(List, ArgOptions).
  142compound({X}, Options) -->
  143    !,
  144    { arg_options(Options, _{priority:1200}, ArgOptions) },
  145    html(span(class('pl-curl'), [ '{', \any(X, ArgOptions), '}' ])).
  146compound(OpTerm, Options) -->
  147    { compound_name_arity(OpTerm, Name, 1),
  148      is_op1(Name, Type, Pri, ArgPri, Options),
  149      \+ Options.get(ignore_ops) == true
  150    },
  151    !,
  152    op1(Type, Pri, OpTerm, ArgPri, Options).
  153compound(OpTerm, Options) -->
  154    { compound_name_arity(OpTerm, Name, 2),
  155      is_op2(Name, LeftPri, Pri, RightPri, Options),
  156      \+ Options.get(ignore_ops) == true
  157    },
  158    !,
  159    op2(Pri, OpTerm, LeftPri, RightPri, Options).
  160compound(Compound, Options) -->
  161    { compound_name_arity(Compound, Name, Arity),
  162      quote_atomic(Name, S, Options.put(embrace, never)),
  163      arg_options(Options, _{priority:999}, ArgOptions),
  164      extra_classes(Classes, Options)
  165    },
  166    html(span(class(['pl-compound'|Classes]),
  167              [ span(class('pl-functor'), S),
  168                '(',
  169                \args(0, Arity, Compound, ArgOptions),
  170                ')'
  171              ])).
  172
  173extra_classes(['pl-level-0'], Options) :-
  174    Options.depth == 0,
  175    !.
  176extra_classes([], _).

 arg_options(+Options, -OptionsOut) is det

 arg_options(+Options, +Extra, -OptionsOut) is det

Increment depth in Options.

  183arg_options(Options, Options.put(depth, NewDepth)) :-
  184    NewDepth is Options.depth+1.
  185arg_options(Options, Extra, Options.put(depth, NewDepth).put(Extra)) :-
  186    NewDepth is Options.depth+1.

 args(+Arg0, +Arity, +Compound, +Options)//

Emit arguments of a compound term.

  192args(Arity, Arity, _, _) --> !.
  193args(I, Arity, Compound, ArgOptions) -->
  194    { NI is I + 1,
  195      arg(NI, Compound, Arg)
  196    },
  197    any(Arg, ArgOptions),
  198    (   {NI == Arity}
  199    ->  []
  200    ;   html(', '),
  201        args(NI, Arity, Compound, ArgOptions)
  202    ).

 list(+List, +Options)//

Emit a list. The List may have an unbound tail.

  208list(List, Options) -->
  209    html(span(class('pl-list'),
  210              ['[', \list_content(List, Options),
  211               ']'
  212              ])).
  213
  214list_content([], _Options) -->
  215    !,
  216    [].
  217list_content([H|T], Options) -->
  218    !,
  219    { arg_options(Options, ArgOptions)
  220    },
  221    any(H, Options),
  222    (   {T == []}
  223    ->  []
  224    ;   { Options.depth + 1 >= Options.max_depth }
  225    ->  html(['|',span(class('pl-ellipsis'), ...)])
  226    ;   {var(T) ; \+ T = [_|_]}
  227    ->  html('|'),
  228        tail(T, ArgOptions)
  229    ;   html(', '),
  230        list_content(T, ArgOptions)
  231    ).
  232
  233tail(Value, Options) -->
  234    {   var(Value)
  235    ->  Class = 'pl-var-tail'
  236    ;   Class = 'pl-nonvar-tail'
  237    },
  238    html(span(class(Class), \any(Value, Options))).

 is_op1(+Name, -Type, -Priority, -ArgPriority, +Options) is semidet

True if Name is an operator taking one argument of Type.

  244is_op1(Name, Type, Pri, ArgPri, Options) :-
  245    operator_module(Module, Options),
  246    current_op(Pri, OpType, Module:Name),
  247    argpri(OpType, Type, Pri, ArgPri),
  248    !.
  249
  250argpri(fx, prefix,  Pri0, Pri) :- Pri is Pri0 - 1.
  251argpri(fy, prefix,  Pri,  Pri).
  252argpri(xf, postfix, Pri0, Pri) :- Pri is Pri0 - 1.
  253argpri(yf, postfix, Pri,  Pri).

 is_op2(+Name, -LeftPri, -Pri, -RightPri, +Options) is semidet

True if Name is an operator taking two arguments of Type.

  259is_op2(Name, LeftPri, Pri, RightPri, Options) :-
  260    operator_module(Module, Options),
  261    current_op(Pri, Type, Module:Name),
  262    infix_argpri(Type, LeftPri, Pri, RightPri),
  263    !.
  264
  265infix_argpri(xfx, ArgPri, Pri, ArgPri) :- ArgPri is Pri - 1.
  266infix_argpri(yfx, Pri, Pri, ArgPri) :- ArgPri is Pri - 1.
  267infix_argpri(xfy, ArgPri, Pri, Pri) :- ArgPri is Pri - 1.

 operator_module(-Module, +Options) is det

Find the module for evaluating operators.

  273operator_module(Module, Options) :-
  274    Module = Options.get(module),
  275    !.
  276operator_module(TypeIn, _) :-
  277    '$module'(TypeIn, TypeIn).

 op1(+Type, +Pri, +Term, +ArgPri, +Options)// is det

  281op1(Type, Pri, Term, ArgPri, Options) -->
  282    { Pri > Options.priority },
  283    !,
  284    html(['(', \op1(Type, Term, ArgPri, Options), ')']).
  285op1(Type, _, Term, ArgPri, Options) -->
  286    op1(Type, Term, ArgPri, Options).
  287
  288op1(prefix, Term, ArgPri, Options) -->
  289    { Term =.. [Functor,Arg],
  290      arg_options(Options, DepthOptions),
  291      FuncOptions = DepthOptions.put(embrace, never),
  292      ArgOptions  = DepthOptions.put(priority, ArgPri),
  293      quote_atomic(Functor, S, FuncOptions),
  294      extra_classes(Classes, Options)
  295    },
  296    html(span(class(['pl-compound'|Classes]),
  297              [ span(class('pl-prefix'), S),
  298                \space(Functor, Arg, FuncOptions, ArgOptions),
  299                \any(Arg, ArgOptions)
  300              ])).
  301op1(postfix, Term, ArgPri, Options) -->
  302    { Term =.. [Functor,Arg],
  303      arg_options(Options, DepthOptions),
  304      ArgOptions = DepthOptions.put(priority, ArgPri),
  305      FuncOptions = DepthOptions.put(embrace, never),
  306      quote_atomic(Functor, S, FuncOptions),
  307      extra_classes(Classes, Options)
  308    },
  309    html(span(class(['pl-compound'|Classes]),
  310              [ \any(Arg, ArgOptions),
  311                \space(Arg, Functor, ArgOptions, FuncOptions),
  312                span(class('pl-postfix'), S)
  313              ])).

 op2(+Pri, +Term, +LeftPri, +RightPri, +Options)// is det

  317op2(Pri, Term, LeftPri, RightPri, Options) -->
  318    { Pri > Options.priority },
  319    !,
  320    html(['(', \op2(Term, LeftPri, RightPri, Options), ')']).
  321op2(_, Term, LeftPri, RightPri, Options) -->
  322    op2(Term, LeftPri, RightPri, Options).
  323
  324op2(Term, LeftPri, RightPri, Options) -->
  325    { Term =.. [Functor,Left,Right],
  326      arg_options(Options, DepthOptions),
  327      LeftOptions  = DepthOptions.put(priority, LeftPri),
  328      FuncOptions  = DepthOptions.put(embrace, never),
  329      RightOptions = DepthOptions.put(priority, RightPri),
  330      (   (   need_space(Left, Functor, LeftOptions, FuncOptions)
  331          ;   need_space(Functor, Right, FuncOptions, RightOptions)
  332          )
  333      ->  Space = ' '
  334      ;   Space = ''
  335      ),
  336      quote_op(Functor, S, Options),
  337      extra_classes(Classes, Options)
  338    },
  339    html(span(class(['pl-compound'|Classes]),
  340              [ \any(Left, LeftOptions),
  341                Space,
  342                span(class('pl-infix'), S),
  343                Space,
  344                \any(Right, RightOptions)
  345              ])).

 space(@T1, @T2, +Options)//

Emit a space if omitting a space between T1 and T2 would cause the two terms to join.

  352space(T1, T2, LeftOptions, RightOptions) -->
  353    { need_space(T1, T2, LeftOptions, RightOptions) },
  354    html(' ').
  355space(_, _, _, _) -->
  356    [].
  357
  358need_space(T1, T2, _, _) :-
  359    (   is_solo(T1)
  360    ;   is_solo(T2)
  361    ),
  362    !,
  363    fail.
  364need_space(T1, T2, LeftOptions, RightOptions) :-
  365    end_code_type(T1, TypeR, LeftOptions.put(side, right)),
  366    end_code_type(T2, TypeL, RightOptions.put(side, left)),
  367    \+ no_space(TypeR, TypeL).
  368
  369no_space(punct, _).
  370no_space(_, punct).
  371no_space(quote(R), quote(L)) :-
  372    !,
  373    R \== L.
  374no_space(alnum, symbol).
  375no_space(symbol, alnum).

 end_code_type(+Term, -Code, Options)

True when code is the first/last character code that is emitted by printing Term using Options.

  382end_code_type(_, Type, Options) :-
  383    Options.depth >= Options.max_depth,
  384    !,
  385    Type = symbol.
  386end_code_type(Term, Type, Options) :-
  387    primitive(Term, _),
  388    !,
  389    quote_atomic(Term, S, Options),
  390    end_type(S, Type, Options).
  391end_code_type(Dict, Type, Options) :-
  392    is_dict(Dict, Tag),
  393    !,
  394    (   Options.side == left
  395    ->  end_code_type(Tag, Type, Options)
  396    ;   Type = punct
  397    ).
  398end_code_type('$VAR'(Var), Type, Options) :-
  399    Options.get(numbervars) == true,
  400    !,
  401    format(string(S), '~W', ['$VAR'(Var), [numbervars(true)]]),
  402    end_type(S, Type, Options).
  403end_code_type(List, Type, _) :-
  404    (   List == []
  405    ;   List = [_|_]
  406    ),
  407    !,
  408    Type = punct.
  409end_code_type(OpTerm, Type, Options) :-
  410    compound_name_arity(OpTerm, Name, 1),
  411    is_op1(Name, OpType, Pri, ArgPri, Options),
  412    \+ Options.get(ignore_ops) == true,
  413    !,
  414    (   Pri > Options.priority
  415    ->  Type = punct
  416    ;   (   OpType == prefix
  417        ->  end_code_type(Name, Type, Options)
  418        ;   arg(1, OpTerm, Arg),
  419            arg_options(Options, ArgOptions),
  420            end_code_type(Arg, Type, ArgOptions.put(priority, ArgPri))
  421        )
  422    ).
  423end_code_type(OpTerm, Type, Options) :-
  424    compound_name_arity(OpTerm, Name, 2),
  425    is_op2(Name, LeftPri, Pri, _RightPri, Options),
  426    \+ Options.get(ignore_ops) == true,
  427    !,
  428    (   Pri > Options.priority
  429    ->  Type = punct
  430    ;   arg(1, OpTerm, Arg),
  431        arg_options(Options, ArgOptions),
  432        end_code_type(Arg, Type, ArgOptions.put(priority, LeftPri))
  433    ).
  434end_code_type(Compound, Type, Options) :-
  435    compound_name_arity(Compound, Name, _),
  436    end_code_type(Name, Type, Options).
  437
  438end_type(S, Type, Options) :-
  439    number(S),
  440    !,
  441    (   (S < 0 ; S == -0.0),
  442        Options.side == left
  443    ->  Type = symbol
  444    ;   Type = alnum
  445    ).
  446end_type(S, Type, Options) :-
  447    Options.side == left,
  448    !,
  449    sub_string(S, 0, 1, _, Start),
  450    syntax_type(Start, Type).
  451end_type(S, Type, _) :-
  452    sub_string(S, _, 1, 0, End),
  453    syntax_type(End, Type).
  454
  455syntax_type("\"", quote(double)) :- !.
  456syntax_type("\'", quote(single)) :- !.
  457syntax_type("\`", quote(back))   :- !.
  458syntax_type(S, Type) :-
  459    string_code(1, S, C),
  460    (   code_type(C, prolog_identifier_continue)
  461    ->  Type = alnum
  462    ;   code_type(C, prolog_symbol)
  463    ->  Type = symbol
  464    ;   code_type(C, space)
  465    ->  Type = layout
  466    ;   Type = punct
  467    ).

 dict(+Term, +Options)//

  472dict(Term, Options) -->
  473    { dict_pairs(Term, Tag, Pairs),
  474      quote_atomic(Tag, S, Options.put(embrace, never)),
  475      arg_options(Options, ArgOptions)
  476    },
  477    html(span(class('pl-dict'),
  478              [ span(class('pl-tag'), S),
  479                '{',
  480                \dict_kvs(Pairs, ArgOptions),
  481                '}'
  482              ])).
  483
  484dict_kvs([], _) --> [].
  485dict_kvs(_, Options) -->
  486    { Options.depth >= Options.max_depth },
  487    !,
  488    html(span(class('pl-ellipsis'), ...)).
  489dict_kvs(KVs, Options) -->
  490    dict_kvs2(KVs, Options).
  491
  492dict_kvs2([K-V|T], Options) -->
  493    { quote_atomic(K, S, Options),
  494      end_code_type(V, VType, Options.put(side, left)),
  495      (   VType == symbol
  496      ->  VSpace = ' '
  497      ;   VSpace = ''
  498      ),
  499      arg_options(Options, ArgOptions)
  500    },
  501    html([ span(class('pl-key'), S),
  502           ':',                             % FIXME: spacing
  503           VSpace,
  504           \any(V, ArgOptions)
  505         ]),
  506    (   {T==[]}
  507    ->  []
  508    ;   html(', '),
  509        dict_kvs2(T, Options)
  510    ).
  511
  512quote_atomic(Float, String, Options) :-
  513    float(Float),
  514    Format = Options.get(float_format),
  515    !,
  516    format(string(String), Format, [Float]).
  517quote_atomic(Plain, String, Options) :-
  518    atomic(Plain),
  519    Format = Options.get(format),
  520    !,
  521    format(string(String), Format, [Plain]).
  522quote_atomic(Plain, String, Options) :-
  523    rational(Plain),
  524    \+ integer(Plain),
  525    !,
  526    operator_module(Module, Options),
  527    format(string(String), '~W', [Plain, [module(Module)]]).
  528quote_atomic(Plain, Plain, _) :-
  529    number(Plain),
  530    !.
  531quote_atomic(Plain, String, Options) :-
  532    Options.get(quoted) == true,
  533    !,
  534    (   Options.get(embrace) == never
  535    ->  format(string(String), '~q', [Plain])
  536    ;   format(string(String), '~W', [Plain, Options])
  537    ).
  538quote_atomic(Var, String, Options) :-
  539    var(Var),
  540    !,
  541    format(string(String), '~W', [Var, Options]).
  542quote_atomic(Plain, Plain, _).
  543
  544quote_op(Op, S, _Options) :-
  545    is_solo(Op),
  546    !,
  547    S = Op.
  548quote_op(Op, S, Options) :-
  549    quote_atomic(Op, S, Options.put(embrace,never)).
  550
  551is_solo(Var) :-
  552    var(Var), !, fail.
  553is_solo(',').
  554is_solo(';').
  555is_solo('!').

 primitive(+Term, -Class) is semidet

True if Term is a primitive term, rendered using the CSS class Class.

  562primitive(Term, Type) :- var(Term),      !, Type = 'pl-avar'.
  563primitive(Term, Type) :- atom(Term),     !, Type = 'pl-atom'.
  564primitive(Term, Type) :- string(Term),   !, Type = 'pl-string'.
  565primitive(Term, Type) :- integer(Term),  !, Type = 'pl-int'.
  566primitive(Term, Type) :- rational(Term), !, Type = 'pl-rational'.
  567primitive(Term, Type) :- float(Term),    !, Type = 'pl-float'.

 primitive_class(+Class0, +Value, -String, -Class) is det

Fixup the CSS class for lexical variations. Used to find quoted atoms.

  574primitive_class('pl-atom', Atom, String, Class) :-
  575    \+ atom_string(Atom, String),
  576    !,
  577    Class = 'pl-quoted-atom'.
  578primitive_class(Class, _, _, Class).
  579
  580
  581                 /*******************************
  582                 *             HOOKS            *
  583                 *******************************/

 blob_rendering(+BlobType, +Blob, +WriteOptions)// is semidet

Hook to render blob atoms as HTML. This hook is called whenever a blob atom is encountered while rendering a compound term as HTML. The blob type is provided to allow efficient indexing without having to examine the blob. If this predicate fails, the blob is rendered as an HTML SPAN with class 'pl-blob' containing BlobType as text.