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

 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.

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

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

Process a compound term.

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

 arg_options(+Options, -OptionsOut) is det

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

Increment depth in Options.

  175arg_options(Options, Options.put(depth, NewDepth)) :-
  176    NewDepth is Options.depth+1.
  177arg_options(Options, Extra, Options.put(depth, NewDepth).put(Extra)) :-
  178    NewDepth is Options.depth+1.

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

Emit arguments of a compound term.

  184args(Arity, Arity, _, _) --> !.
  185args(I, Arity, Compound, ArgOptions) -->
  186    { NI is I + 1,
  187      arg(NI, Compound, Arg)
  188    },
  189    any(Arg, ArgOptions),
  190    (   {NI == Arity}
  191    ->  []
  192    ;   html(', '),
  193        args(NI, Arity, Compound, ArgOptions)
  194    ).

 list(+List, +Options)//

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

  200list(List, Options) -->
  201    html(span(class('pl-list'),
  202              ['[', \list_content(List, Options),
  203               ']'
  204              ])).
  205
  206list_content([], _Options) -->
  207    !,
  208    [].
  209list_content([H|T], Options) -->
  210    !,
  211    { arg_options(Options, ArgOptions)
  212    },
  213    any(H, Options),
  214    (   {T == []}
  215    ->  []
  216    ;   { Options.depth + 1 >= Options.max_depth }
  217    ->  html(['|',span(class('pl-ellipsis'), ...)])
  218    ;   {var(T) ; \+ T = [_|_]}
  219    ->  html('|'),
  220        tail(T, ArgOptions)
  221    ;   html(', '),
  222        list_content(T, ArgOptions)
  223    ).
  224
  225tail(Value, Options) -->
  226    {   var(Value)
  227    ->  Class = 'pl-var-tail'
  228    ;   Class = 'pl-nonvar-tail'
  229    },
  230    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.

  236is_op1(Name, Type, Pri, ArgPri, Options) :-
  237    operator_module(Module, Options),
  238    current_op(Pri, OpType, Module:Name),
  239    argpri(OpType, Type, Pri, ArgPri),
  240    !.
  241
  242argpri(fx, prefix,  Pri0, Pri) :- Pri is Pri0 - 1.
  243argpri(fy, prefix,  Pri,  Pri).
  244argpri(xf, postfix, Pri0, Pri) :- Pri is Pri0 - 1.
  245argpri(yf, postfix, Pri,  Pri).

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

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

  251is_op2(Name, LeftPri, Pri, RightPri, Options) :-
  252    operator_module(Module, Options),
  253    current_op(Pri, Type, Module:Name),
  254    infix_argpri(Type, LeftPri, Pri, RightPri),
  255    !.
  256
  257infix_argpri(xfx, ArgPri, Pri, ArgPri) :- ArgPri is Pri - 1.
  258infix_argpri(yfx, Pri, Pri, ArgPri) :- ArgPri is Pri - 1.
  259infix_argpri(xfy, ArgPri, Pri, Pri) :- ArgPri is Pri - 1.

 operator_module(-Module, +Options) is det

Find the module for evaluating operators.

  265operator_module(Module, Options) :-
  266    Module = Options.get(module),
  267    !.
  268operator_module(TypeIn, _) :-
  269    '$module'(TypeIn, TypeIn).

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

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

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

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

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

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

  344space(T1, T2, LeftOptions, RightOptions) -->
  345    { need_space(T1, T2, LeftOptions, RightOptions) },
  346    html(' ').
  347space(_, _, _, _) -->
  348    [].
  349
  350need_space(T1, T2, _, _) :-
  351    (   is_solo(T1)
  352    ;   is_solo(T2)
  353    ),
  354    !,
  355    fail.
  356need_space(T1, T2, LeftOptions, RightOptions) :-
  357    end_code_type(T1, TypeR, LeftOptions.put(side, right)),
  358    end_code_type(T2, TypeL, RightOptions.put(side, left)),
  359    \+ no_space(TypeR, TypeL).
  360
  361no_space(punct, _).
  362no_space(_, punct).
  363no_space(quote(R), quote(L)) :-
  364    !,
  365    R \== L.
  366no_space(alnum, symbol).
  367no_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.

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

 dict(+Term, +Options)//

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

 primitive(+Term, -Class) is semidet

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

  554primitive(Term, Type) :- var(Term),      !, Type = 'pl-avar'.
  555primitive(Term, Type) :- atom(Term),     !, Type = 'pl-atom'.
  556primitive(Term, Type) :- string(Term),   !, Type = 'pl-string'.
  557primitive(Term, Type) :- integer(Term),  !, Type = 'pl-int'.
  558primitive(Term, Type) :- rational(Term), !, Type = 'pl-rational'.
  559primitive(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.

  566primitive_class('pl-atom', Atom, String, Class) :-
  567    \+ atom_string(Atom, String),
  568    !,
  569    Class = 'pl-quoted-atom'.
  570primitive_class(Class, _, _, Class).
  571
  572
  573                 /*******************************
  574                 *             HOOKS            *
  575                 *******************************/

 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.