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
   46
   47/** <module> Represent Prolog terms as HTML
   48
   49This file is primarily designed to   support running Prolog applications
   50over the web. It provides a   replacement for write_term/2 which renders
   51terms as structured HTML.
   52*/
   53
   54%!  term(@Term, +Options)// is det.
   55%
   56%   Render a Prolog term as  a   structured  HTML  tree. Options are
   57%   passed to write_term/3. In addition,   the following options are
   58%   processed:
   59%
   60%     - format(+Format)
   61%     Used for atomic values.  Typically this is used to
   62%     render a single value.
   63%     - float_format(+Format)
   64%     If a float is rendered, it is rendered using
   65%     `format(string(S), Format, [Float])`
   66%
   67%   @tbd    Cyclic terms.
   68%   @tbd    Attributed terms.
   69%   @tbd    Portray
   70%   @tbd    Test with Ulrich's write test set.
   71%   @tbd    Deal with numbervars and canonical.
   72
   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).
  119
  120%!  compound(+Compound, +Options)// is det.
  121%
  122%   Process a compound term.
  123
  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([], _).
  177
  178%!  arg_options(+Options, -OptionsOut) is det.
  179%!  arg_options(+Options, +Extra, -OptionsOut) is det.
  180%
  181%   Increment depth in Options.
  182
  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.
  187
  188%!  args(+Arg0, +Arity, +Compound, +Options)//
  189%
  190%   Emit arguments of a compound term.
  191
  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    ).
  203
  204%!  list(+List, +Options)//
  205%
  206%   Emit a list.  The List may have an unbound tail.
  207
  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))).
  239
  240%!  is_op1(+Name, -Type, -Priority, -ArgPriority, +Options) is semidet.
  241%
  242%   True if Name is an operator taking one argument of Type.
  243
  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).
  254
  255%!  is_op2(+Name, -LeftPri, -Pri, -RightPri, +Options) is semidet.
  256%
  257%   True if Name is an operator taking two arguments of Type.
  258
  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.
  268
  269%!  operator_module(-Module, +Options) is det.
  270%
  271%   Find the module for evaluating operators.
  272
  273operator_module(Module, Options) :-
  274    Module = Options.get(module),
  275    !.
  276operator_module(TypeIn, _) :-
  277    '$module'(TypeIn, TypeIn).
  278
  279%!  op1(+Type, +Pri, +Term, +ArgPri, +Options)// is det.
  280
  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              ])).
  314
  315%!  op2(+Pri, +Term, +LeftPri, +RightPri, +Options)// is det.
  316
  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              ])).
  346
  347%!  space(@T1, @T2, +Options)//
  348%
  349%   Emit a space if omitting a space   between T1 and T2 would cause
  350%   the two terms to join.
  351
  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).
  376
  377%!  end_code_type(+Term, -Code, Options)
  378%
  379%   True when code is the first/last character code that is emitted
  380%   by printing Term using Options.
  381
  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    ).
  468
  469
  470%!  dict(+Term, +Options)//
  471
  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('!').
  556
  557%!  primitive(+Term, -Class) is semidet.
  558%
  559%   True if Term is a primitive term, rendered using the CSS
  560%   class Class.
  561
  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'.
  568
  569%!  primitive_class(+Class0, +Value, -String, -Class) is det.
  570%
  571%   Fixup the CSS class for lexical variations.  Used to find
  572%   quoted atoms.
  573
  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                 *******************************/
  584
  585%!  blob_rendering(+BlobType, +Blob, +WriteOptions)// is semidet.
  586%
  587%   Hook to render blob atoms as HTML.  This hook is called whenever
  588%   a blob atom is encountered while   rendering  a compound term as
  589%   HTML. The blob type is  provided   to  allow  efficient indexing
  590%   without having to examine the blob. If this predicate fails, the
  591%   blob is rendered as an HTML SPAN with class 'pl-blob' containing
  592%   BlobType as text.