View source with formatted comments or as raw
    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%     - format(+Format)
   60%     Used for atomic values.  Typically this is used to
   61%     render a single value.
   62%     - float_format(+Format)
   63%     If a float is rendered, it is rendered using
   64%     `format(string(S), Format, [Float])`
   65%
   66%   @tbd    Cyclic terms.
   67%   @tbd    Attributed terms.
   68%   @tbd    Portray
   69%   @tbd    Test with Ulrich's write test set.
   70%   @tbd    Deal with numbervars and canonical.
   71
   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).
  111
  112%!  compound(+Compound, +Options)// is det.
  113%
  114%   Process a compound term.
  115
  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([], _).
  169
  170%!  arg_options(+Options, -OptionsOut) is det.
  171%!  arg_options(+Options, +Extra, -OptionsOut) is det.
  172%
  173%   Increment depth in Options.
  174
  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.
  179
  180%!  args(+Arg0, +Arity, +Compound, +Options)//
  181%
  182%   Emit arguments of a compound term.
  183
  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    ).
  195
  196%!  list(+List, +Options)//
  197%
  198%   Emit a list.  The List may have an unbound tail.
  199
  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))).
  231
  232%!  is_op1(+Name, -Type, -Priority, -ArgPriority, +Options) is semidet.
  233%
  234%   True if Name is an operator taking one argument of Type.
  235
  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).
  246
  247%!  is_op2(+Name, -LeftPri, -Pri, -RightPri, +Options) is semidet.
  248%
  249%   True if Name is an operator taking two arguments of Type.
  250
  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.
  260
  261%!  operator_module(-Module, +Options) is det.
  262%
  263%   Find the module for evaluating operators.
  264
  265operator_module(Module, Options) :-
  266    Module = Options.get(module),
  267    !.
  268operator_module(TypeIn, _) :-
  269    '$module'(TypeIn, TypeIn).
  270
  271%!  op1(+Type, +Pri, +Term, +ArgPri, +Options)// is det.
  272
  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              ])).
  306
  307%!  op2(+Pri, +Term, +LeftPri, +RightPri, +Options)// is det.
  308
  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              ])).
  338
  339%!  space(@T1, @T2, +Options)//
  340%
  341%   Emit a space if omitting a space   between T1 and T2 would cause
  342%   the two terms to join.
  343
  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).
  368
  369%!  end_code_type(+Term, -Code, Options)
  370%
  371%   True when code is the first/last character code that is emitted
  372%   by printing Term using Options.
  373
  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    ).
  460
  461
  462%!  dict(+Term, +Options)//
  463
  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('!').
  548
  549%!  primitive(+Term, -Class) is semidet.
  550%
  551%   True if Term is a primitive term, rendered using the CSS
  552%   class Class.
  553
  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'.
  560
  561%!  primitive_class(+Class0, +Value, -String, -Class) is det.
  562%
  563%   Fixup the CSS class for lexical variations.  Used to find
  564%   quoted atoms.
  565
  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                 *******************************/
  576
  577%!  blob_rendering(+BlobType, +Blob, +WriteOptions)// is semidet.
  578%
  579%   Hook to render blob atoms as HTML.  This hook is called whenever
  580%   a blob atom is encountered while   rendering  a compound term as
  581%   HTML. The blob type is  provided   to  allow  efficient indexing
  582%   without having to examine the blob. If this predicate fails, the
  583%   blob is rendered as an HTML SPAN with class 'pl-blob' containing
  584%   BlobType as text.