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
   46/** <module> Represent Prolog terms as HTML
   47
   48This file is primarily designed to   support running Prolog applications
   49over the web. It provides a   replacement for write_term/2 which renders
   50terms as structured HTML.
   51*/
   52
   53%!  term(@Term, +Options)// is det.
   54%
   55%   Render a Prolog term as  a   structured  HTML  tree. Options are
   56%   passed to write_term/3. In addition,   the following options are
   57%   processed:
   58%
   59%     - float_format(+Format)
   60%     If a float is rendered, it is rendered using
   61%     `format(string(S), Format, [Float])`%
   62%
   63%   @tbd    Cyclic terms.
   64%   @tbd    Attributed terms.
   65%   @tbd    Portray
   66%   @tbd    Test with Ulrich's write test set.
   67%   @tbd    Deal with numbervars and canonical.
   68
   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).
  108
  109%!  compound(+Compound, +Options)// is det.
  110%
  111%   Process a compound term.
  112
  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([], _).
  166
  167%!  arg_options(+Options, -OptionsOut) is det.
  168%!  arg_options(+Options, +Extra, -OptionsOut) is det.
  169%
  170%   Increment depth in Options.
  171
  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.
  176
  177%!  args(+Arg0, +Arity, +Compound, +Options)//
  178%
  179%   Emit arguments of a compound term.
  180
  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    ).
  192
  193%!  list(+List, +Options)//
  194%
  195%   Emit a list.  The List may have an unbound tail.
  196
  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))).
  228
  229%!  is_op1(+Name, -Type, -Priority, -ArgPriority, +Options) is semidet.
  230%
  231%   True if Name is an operator taking one argument of Type.
  232
  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).
  243
  244%!  is_op2(+Name, -LeftPri, -Pri, -RightPri, +Options) is semidet.
  245%
  246%   True if Name is an operator taking two arguments of Type.
  247
  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.
  257
  258%!  operator_module(-Module, +Options) is det.
  259%
  260%   Find the module for evaluating operators.
  261
  262operator_module(Module, Options) :-
  263    Module = Options.get(module),
  264    !.
  265operator_module(TypeIn, _) :-
  266    '$module'(TypeIn, TypeIn).
  267
  268%!  op1(+Type, +Pri, +Term, +ArgPri, +Options)// is det.
  269
  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              ])).
  303
  304%!  op2(+Pri, +Term, +LeftPri, +RightPri, +Options)// is det.
  305
  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              ])).
  335
  336%!  space(@T1, @T2, +Options)//
  337%
  338%   Emit a space if omitting a space   between T1 and T2 would cause
  339%   the two terms to join.
  340
  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).
  365
  366%!  end_code_type(+Term, -Code, Options)
  367%
  368%   True when code is the first/last character code that is emitted
  369%   by printing Term using Options.
  370
  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    ).
  453
  454
  455%!  dict(+Term, +Options)//
  456
  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('!').
  530
  531%!  primitive(+Term, -Class) is semidet.
  532%
  533%   True if Term is a primitive term, rendered using the CSS
  534%   class Class.
  535
  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'.
  541
  542%!  primitive_class(+Class0, +Value, -String, -Class) is det.
  543%
  544%   Fixup the CSS class for lexical variations.  Used to find
  545%   quoted atoms.
  546
  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                 *******************************/
  557
  558%!  blob_rendering(+BlobType, +Blob, +WriteOptions)// is semidet.
  559%
  560%   Hook to render blob atoms as HTML.  This hook is called whenever
  561%   a blob atom is encountered while   rendering  a compound term as
  562%   HTML. The blob type is  provided   to  allow  efficient indexing
  563%   without having to examine the blob. If this predicate fails, the
  564%   blob is rendered as an HTML SPAN with class 'pl-blob' containing
  565%   BlobType as text.
  566
  567:- multifile blob_rendering//3.