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      op1(Name, Type, Pri, ArgPri, Options),
 138      \+ Options.get(ignore_ops) == true,
 139      arg_options(Options, ArgOptions)
 140    },
 141    !,
 142    op1(Type, Pri, OpTerm, ArgPri, ArgOptions).
 143compound(OpTerm, Options) -->
 144    { compound_name_arity(OpTerm, Name, 2),
 145      op2(Name, LeftPri, Pri, RightPri, Options),
 146      \+ Options.get(ignore_ops) == true,
 147      arg_options(Options, ArgOptions)
 148    },
 149    !,
 150    op2(Pri, OpTerm, LeftPri, RightPri, ArgOptions).
 151compound(Compound, Options) -->
 152    { compound_name_arity(Compound, Name, Arity),
 153      quote_atomic(Name, S, Options.put(embrace, never)),
 154      arg_options(Options, _{priority:999}, ArgOptions)
 155    },
 156    html(span(class('pl-compound'),
 157              [ span(class('pl-functor'), S),
 158                '(',
 159                \args(0, Arity, Compound, ArgOptions),
 160                ')'
 161              ])).
 162
 163%!  arg_options(+Options, -OptionsOut) is det.
 164%!  arg_options(+Options, +Extra, -OptionsOut) is det.
 165%
 166%   Increment depth in Options.
 167
 168arg_options(Options, Options.put(depth, NewDepth)) :-
 169    NewDepth is Options.depth+1.
 170arg_options(Options, Extra, Options.put(depth, NewDepth).put(Extra)) :-
 171    NewDepth is Options.depth+1.
 172
 173%!  args(+Arg0, +Arity, +Compound, +Options)//
 174%
 175%   Emit arguments of a compound term.
 176
 177args(Arity, Arity, _, _) --> !.
 178args(I, Arity, Compound, ArgOptions) -->
 179    { NI is I + 1,
 180      arg(NI, Compound, Arg)
 181    },
 182    any(Arg, ArgOptions),
 183    (   {NI == Arity}
 184    ->  []
 185    ;   html(', '),
 186        args(NI, Arity, Compound, ArgOptions)
 187    ).
 188
 189%!  list(+List, +Options)//
 190%
 191%   Emit a list.  The List may have an unbound tail.
 192
 193list(List, Options) -->
 194    html(span(class('pl-list'),
 195              ['[', \list_content(List, Options),
 196               ']'
 197              ])).
 198
 199list_content([], _Options) -->
 200    !,
 201    [].
 202list_content([H|T], Options) -->
 203    !,
 204    { arg_options(Options, ArgOptions)
 205    },
 206    any(H, Options),
 207    (   {T == []}
 208    ->  []
 209    ;   { Options.depth + 1 >= Options.max_depth }
 210    ->  html(['|',span(class('pl-ellipsis'), ...)])
 211    ;   {var(T) ; \+ T = [_|_]}
 212    ->  html('|'),
 213        tail(T, ArgOptions)
 214    ;   html(', '),
 215        list_content(T, ArgOptions)
 216    ).
 217
 218tail(Value, Options) -->
 219    {   var(Value)
 220    ->  Class = 'pl-var-tail'
 221    ;   Class = 'pl-nonvar-tail'
 222    },
 223    html(span(class(Class), \any(Value, Options))).
 224
 225%!  op1(+Name, -Type, -Priority, -ArgPriority, +Options) is semidet.
 226%
 227%   True if Name is an operator taking one argument of Type.
 228
 229op1(Name, Type, Pri, ArgPri, Options) :-
 230    operator_module(Module, Options),
 231    current_op(Pri, OpType, Module:Name),
 232    argpri(OpType, Type, Pri, ArgPri),
 233    !.
 234
 235argpri(fx, prefix,  Pri0, Pri) :- Pri is Pri0 - 1.
 236argpri(fy, prefix,  Pri,  Pri).
 237argpri(xf, postfix, Pri0, Pri) :- Pri is Pri0 - 1.
 238argpri(yf, postfix, Pri,  Pri).
 239
 240%!  op2(+Name, -LeftPri, -Pri, -RightPri, +Options) is semidet.
 241%
 242%   True if Name is an operator taking two arguments of Type.
 243
 244op2(Name, LeftPri, Pri, RightPri, Options) :-
 245    operator_module(Module, Options),
 246    current_op(Pri, Type, Module:Name),
 247    infix_argpri(Type, LeftPri, Pri, RightPri),
 248    !.
 249
 250infix_argpri(xfx, ArgPri, Pri, ArgPri) :- ArgPri is Pri - 1.
 251infix_argpri(yfx, Pri, Pri, ArgPri) :- ArgPri is Pri - 1.
 252infix_argpri(xfy, ArgPri, Pri, Pri) :- ArgPri is Pri - 1.
 253
 254%!  operator_module(-Module, +Options) is det.
 255%
 256%   Find the module for evaluating operators.
 257
 258operator_module(Module, Options) :-
 259    Module = Options.get(module),
 260    !.
 261operator_module(TypeIn, _) :-
 262    '$module'(TypeIn, TypeIn).
 263
 264%!  op1(+Type, +Pri, +Term, +ArgPri, +Options)// is det.
 265
 266op1(Type, Pri, Term, ArgPri, Options) -->
 267    { Pri > Options.priority },
 268    !,
 269    html(['(', \op1(Type, Term, ArgPri, Options), ')']).
 270op1(Type, _, Term, ArgPri, Options) -->
 271    op1(Type, Term, ArgPri, Options).
 272
 273op1(prefix, Term, ArgPri, Options) -->
 274    { Term =.. [Functor,Arg],
 275      FuncOptions = Options.put(embrace, never),
 276      ArgOptions  = Options.put(priority, ArgPri),
 277      quote_atomic(Functor, S, FuncOptions)
 278    },
 279    html(span(class('pl-compound'),
 280              [ span(class('pl-prefix'), S),
 281                \space(Functor, Arg, FuncOptions, ArgOptions),
 282                \any(Arg, ArgOptions)
 283              ])).
 284op1(postfix, Term, ArgPri, Options) -->
 285    { Term =.. [Functor,Arg],
 286      ArgOptions = Options.put(priority, ArgPri),
 287      FuncOptions = Options.put(embrace, never),
 288      quote_atomic(Functor, S, FuncOptions)
 289    },
 290    html(span(class('pl-compound'),
 291              [ \any(Arg, ArgOptions),
 292                \space(Arg, Functor, ArgOptions, FuncOptions),
 293                span(class('pl-postfix'), S)
 294              ])).
 295
 296%!  op2(+Pri, +Term, +LeftPri, +RightPri, +Options)// is det.
 297
 298op2(Pri, Term, LeftPri, RightPri, Options) -->
 299    { Pri > Options.priority },
 300    !,
 301    html(['(', \op2(Term, LeftPri, RightPri, Options), ')']).
 302op2(_, Term, LeftPri, RightPri, Options) -->
 303    op2(Term, LeftPri, RightPri, Options).
 304
 305op2(Term, LeftPri, RightPri, Options) -->
 306    { Term =.. [Functor,Left,Right],
 307      LeftOptions  = Options.put(priority, LeftPri),
 308      FuncOptions  = Options.put(embrace, never),
 309      RightOptions = Options.put(priority, RightPri),
 310      (   (   need_space(Left, Functor, LeftOptions, FuncOptions)
 311          ;   need_space(Functor, Right, FuncOptions, RightOptions)
 312          )
 313      ->  Space = ' '
 314      ;   Space = ''
 315      ),
 316      quote_op(Functor, S, Options)
 317    },
 318    html(span(class('pl-compound'),
 319              [ \any(Left, LeftOptions),
 320                Space,
 321                span(class('pl-infix'), S),
 322                Space,
 323                \any(Right, RightOptions)
 324              ])).
 325
 326%!  space(@T1, @T2, +Options)//
 327%
 328%   Emit a space if omitting a space   between T1 and T2 would cause
 329%   the two terms to join.
 330
 331space(T1, T2, LeftOptions, RightOptions) -->
 332    { need_space(T1, T2, LeftOptions, RightOptions) },
 333    html(' ').
 334space(_, _, _, _) -->
 335    [].
 336
 337need_space(T1, T2, _, _) :-
 338    (   is_solo(T1)
 339    ;   is_solo(T2)
 340    ),
 341    !,
 342    fail.
 343need_space(T1, T2, LeftOptions, RightOptions) :-
 344    end_code_type(T1, TypeR, LeftOptions.put(side, right)),
 345    end_code_type(T2, TypeL, RightOptions.put(side, left)),
 346    \+ no_space(TypeR, TypeL).
 347
 348no_space(punct, _).
 349no_space(_, punct).
 350no_space(quote(R), quote(L)) :-
 351    !,
 352    R \== L.
 353no_space(alnum, symbol).
 354no_space(symbol, alnum).
 355
 356%!  end_code_type(+Term, -Code, Options)
 357%
 358%   True when code is the first/last character code that is emitted
 359%   by printing Term using Options.
 360
 361end_code_type(_, Type, Options) :-
 362    Options.depth >= Options.max_depth,
 363    !,
 364    Type = symbol.
 365end_code_type(Term, Type, Options) :-
 366    primitive(Term, _),
 367    !,
 368    quote_atomic(Term, S, Options),
 369    end_type(S, Type, Options).
 370end_code_type(Dict, Type, Options) :-
 371    is_dict(Dict, Tag),
 372    !,
 373    (   Options.side == left
 374    ->  end_code_type(Tag, Type, Options)
 375    ;   Type = punct
 376    ).
 377end_code_type('$VAR'(Var), Type, Options) :-
 378    Options.get(numbervars) == true,
 379    !,
 380    format(string(S), '~W', ['$VAR'(Var), [numbervars(true)]]),
 381    end_type(S, Type, Options).
 382end_code_type(List, Type, _) :-
 383    (   List == []
 384    ;   List = [_|_]
 385    ),
 386    !,
 387    Type = punct.
 388end_code_type(OpTerm, Type, Options) :-
 389    compound_name_arity(OpTerm, Name, 1),
 390    op1(Name, Type, Pri, ArgPri, Options),
 391    \+ Options.get(ignore_ops) == true,
 392    !,
 393    (   Pri > Options.priority
 394    ->  Type = punct
 395    ;   (   Type == prefix
 396        ->  end_code_type(Name, Type, Options)
 397        ;   arg(1, OpTerm, Arg),
 398            arg_options(Options, ArgOptions),
 399            end_code_type(Arg, Type, ArgOptions.put(priority, ArgPri))
 400        )
 401    ).
 402end_code_type(OpTerm, Type, Options) :-
 403    compound_name_arity(OpTerm, Name, 2),
 404    op2(Name, LeftPri, Pri, _RightPri, Options),
 405    \+ Options.get(ignore_ops) == true,
 406    !,
 407    (   Pri > Options.priority
 408    ->  Type = punct
 409    ;   arg(1, OpTerm, Arg),
 410        arg_options(Options, ArgOptions),
 411        end_code_type(Arg, Type, ArgOptions.put(priority, LeftPri))
 412    ).
 413end_code_type(Compound, Type, Options) :-
 414    compound_name_arity(Compound, Name, _),
 415    end_code_type(Name, Type, Options).
 416
 417end_type(S, Type, _Options) :-
 418    number(S),
 419    !,
 420    Type = alnum.
 421end_type(S, Type, Options) :-
 422    Options.side == left,
 423    !,
 424    sub_string(S, 0, 1, _, Start),
 425    syntax_type(Start, Type).
 426end_type(S, Type, _) :-
 427    sub_string(S, _, 1, 0, End),
 428    syntax_type(End, Type).
 429
 430syntax_type("\"", quote(double)) :- !.
 431syntax_type("\'", quote(single)) :- !.
 432syntax_type("\`", quote(back))   :- !.
 433syntax_type(S, Type) :-
 434    string_code(1, S, C),
 435    (   code_type(C, prolog_identifier_continue)
 436    ->  Type = alnum
 437    ;   code_type(C, prolog_symbol)
 438    ->  Type = symbol
 439    ;   code_type(C, space)
 440    ->  Type = layout
 441    ;   Type = punct
 442    ).
 443
 444
 445%!  dict(+Term, +Options)//
 446
 447dict(Term, Options) -->
 448    { dict_pairs(Term, Tag, Pairs),
 449      quote_atomic(Tag, S, Options.put(embrace, never)),
 450      arg_options(Options, ArgOptions)
 451    },
 452    html(span(class('pl-dict'),
 453              [ span(class('pl-tag'), S),
 454                '{',
 455                \dict_kvs(Pairs, ArgOptions),
 456                '}'
 457              ])).
 458
 459dict_kvs([], _) --> [].
 460dict_kvs(_, Options) -->
 461    { Options.depth >= Options.max_depth },
 462    !,
 463    html(span(class('pl-ellipsis'), ...)).
 464dict_kvs(KVs, Options) -->
 465    dict_kvs2(KVs, Options).
 466
 467dict_kvs2([K-V|T], Options) -->
 468    { quote_atomic(K, S, Options),
 469      end_code_type(V, VType, Options.put(side, left)),
 470      (   VType == symbol
 471      ->  VSpace = ' '
 472      ;   VSpace = ''
 473      ),
 474      arg_options(Options, ArgOptions)
 475    },
 476    html([ span(class('pl-key'), S),
 477           ':',                             % FIXME: spacing
 478           VSpace,
 479           \any(V, ArgOptions)
 480         ]),
 481    (   {T==[]}
 482    ->  []
 483    ;   html(', '),
 484        dict_kvs2(T, Options)
 485    ).
 486
 487quote_atomic(Float, String, Options) :-
 488    float(Float),
 489    Format = Options.get(float_format),
 490    !,
 491    format(string(String), Format, [Float]).
 492quote_atomic(Plain, Plain, _) :-
 493    number(Plain),
 494    !.
 495quote_atomic(Plain, String, Options) :-
 496    Options.get(quoted) == true,
 497    !,
 498    (   Options.get(embrace) == never
 499    ->  format(string(String), '~q', [Plain])
 500    ;   format(string(String), '~W', [Plain, Options])
 501    ).
 502quote_atomic(Var, String, Options) :-
 503    var(Var),
 504    !,
 505    format(string(String), '~W', [Var, Options]).
 506quote_atomic(Plain, Plain, _).
 507
 508quote_op(Op, S, _Options) :-
 509    is_solo(Op),
 510    !,
 511    S = Op.
 512quote_op(Op, S, Options) :-
 513    quote_atomic(Op, S, Options.put(embrace,never)).
 514
 515is_solo(Var) :-
 516    var(Var), !, fail.
 517is_solo(',').
 518is_solo(';').
 519is_solo('!').
 520
 521%!  primitive(+Term, -Class) is semidet.
 522%
 523%   True if Term is a primitive term, rendered using the CSS
 524%   class Class.
 525
 526primitive(Term, Type) :- var(Term),     !, Type = 'pl-avar'.
 527primitive(Term, Type) :- atom(Term),    !, Type = 'pl-atom'.
 528primitive(Term, Type) :- string(Term),  !, Type = 'pl-string'.
 529primitive(Term, Type) :- integer(Term), !, Type = 'pl-int'.
 530primitive(Term, Type) :- float(Term),   !, Type = 'pl-float'.
 531
 532%!  primitive_class(+Class0, +Value, -String, -Class) is det.
 533%
 534%   Fixup the CSS class for lexical variations.  Used to find
 535%   quoted atoms.
 536
 537primitive_class('pl-atom', Atom, String, Class) :-
 538    \+ atom_string(Atom, String),
 539    !,
 540    Class = 'pl-quoted-atom'.
 541primitive_class(Class, _, _, Class).
 542
 543
 544                 /*******************************
 545                 *             HOOKS            *
 546                 *******************************/
 547
 548%!  blob_rendering(+BlobType, +Blob, +WriteOptions)// is semidet.
 549%
 550%   Hook to render blob atoms as HTML.  This hook is called whenever
 551%   a blob atom is encountered while   rendering  a compound term as
 552%   HTML. The blob type is  provided   to  allow  efficient indexing
 553%   without having to examine the blob. If this predicate fails, the
 554%   blob is rendered as an HTML SPAN with class 'pl-blob' containing
 555%   BlobType as text.
 556
 557:- multifile blob_rendering//3.