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:

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.

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

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

Process a compound term.

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

 arg_options(+Options, -OptionsOut) is det

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

Increment depth in Options.

  172arg_options(Options, Options.put(depth, NewDepth)) :-
  173    NewDepth is Options.depth+1.
  174arg_options(Options, Extra, Options.put(depth, NewDepth).put(Extra)) :-
  175    NewDepth is Options.depth+1.

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

Emit arguments of a compound term.

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

 list(+List, +Options)//

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

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

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

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

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

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

 operator_module(-Module, +Options) is det

Find the module for evaluating operators.

  262operator_module(Module, Options) :-
  263    Module = Options.get(module),
  264    !.
  265operator_module(TypeIn, _) :-
  266    '$module'(TypeIn, TypeIn).

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

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

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

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

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

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

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

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

 dict(+Term, +Options)//

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

 primitive(+Term, -Class) is semidet

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

  536primitive(Term, Type) :- var(Term),     !, Type = 'pl-avar'.
  537primitive(Term, Type) :- atom(Term),    !, Type = 'pl-atom'.
  538primitive(Term, Type) :- string(Term),  !, Type = 'pl-string'.
  539primitive(Term, Type) :- integer(Term), !, Type = 'pl-int'.
  540primitive(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.

  547primitive_class('pl-atom', Atom, String, Class) :-
  548    \+ atom_string(Atom, String),
  549    !,
  550    Class = 'pl-quoted-atom'.
  551primitive_class(Class, _, _, Class).
  552
  553
  554                 /*******************************
  555                 *             HOOKS            *
  556                 *******************************/

 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.

  567:- multifile blob_rendering//3.