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)  2006-2017, University of Amsterdam
    7                              VU University Amsterdam
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   35
   36:- module(pldoc_htmlsrc,
   37          [ source_to_html/3            % +Source, +Out, +Options
   38          ]).   39:- use_module(library(apply)).   40:- use_module(library(option)).   41:- use_module(library(debug)).   42:- use_module(library(lists)).   43:- use_module(library(prolog_colour)).   44:- use_module(doc_colour).   45:- use_module(doc_html).   46:- use_module(doc_wiki).   47:- use_module(doc_modes).   48:- use_module(doc_process).   49:- use_module(library(http/html_write)).   50:- use_module(library(http/http_path)).   51:- use_module(library(prolog_xref)).   52
   53:- meta_predicate
   54    source_to_html(+, +, :).   55
   56
   57/** <module> HTML source pretty-printer
   58
   59This module colourises Prolog  source  using   HTML+CSS  using  the same
   60cross-reference based technology as used by PceEmacs.
   61
   62@tbd    Create hyper-links to documentation and definitions.
   63@author Jan Wielemaker
   64*/
   65
   66:- predicate_options(source_to_html/3, 3,
   67                     [ format_comments(boolean),
   68                       header(boolean),
   69                       skin(callable),
   70                       stylesheets(list),
   71                       title(atom)
   72                     ]).   73
   74
   75:- thread_local
   76    lineno/0,                       % print line-no on next output
   77    nonl/0,                         % previous tag implies nl (block level)
   78    id/1.                           % Emitted ids
   79
   80%!  source_to_html(+In:filename, +Out, :Options) is det.
   81%
   82%   Colourise Prolog source as HTML. The idea   is to first create a
   83%   sequence of fragments and  then  to   apply  these  to the code.
   84%   Options are:
   85%
   86%     * format_comments(+Boolean)
   87%     If =true= (default), use PlDoc formatting for structured
   88%     comments.
   89%
   90%   Other options are passed to the following predicates:
   91%
   92%     * print_html_head/2
   93%     * print_html_footer/2.
   94%     * html_fragments/6
   95%
   96%   @arg In         A filename.  Can also be an abstract name,
   97%                   which is subject to library(prolog_source)
   98%                   abstract file handling. See
   99%                   prolog_open_source/2.  Note that this cannot
  100%                   be a stream as we need to read the file three
  101%                   times: (1) xref, (2) assign colours and (3)
  102%                   generate HTML.
  103%   @arg Out        Term stream(Stream) or filename specification
  104
  105source_to_html(Src, stream(Out), MOptions) :-
  106    !,
  107    meta_options(is_meta, MOptions, Options),
  108    (   option(title(_), Options)
  109    ->  HeadOptions = Options
  110    ;   file_base_name(Src, Title),
  111        HeadOptions = [title(Title)|Options]
  112    ),
  113    retractall(lineno),             % play safe
  114    retractall(nonl),               % play safe
  115    retractall(id(_)),
  116    colour_fragments(Src, Fragments),
  117    setup_call_cleanup(
  118        ( open_source(Src, In),
  119          asserta(user:thread_message_hook(_,_,_), Ref)
  120        ),
  121        ( print_html_head(Out, HeadOptions),
  122          html_fragments(Fragments, In, Out, [], State, Options),
  123          copy_rest(In, Out, State, State1),
  124          pop_state(State1, Out, In)
  125        ),
  126        ( erase(Ref),
  127          close(In)
  128        )),
  129    print_html_footer(Out, Options).
  130source_to_html(Src, FileSpec, Options) :-
  131    absolute_file_name(FileSpec, OutFile, [access(write)]),
  132    setup_call_cleanup(
  133        open(OutFile, write, Out, [encoding(utf8)]),
  134        source_to_html(Src, stream(Out), Options),
  135        close(Out)).
  136
  137open_source(Id, Stream) :-
  138    prolog:xref_open_source(Id, Stream),
  139    !.
  140open_source(File, Stream) :-
  141    open(File, read, Stream).
  142
  143is_meta(skin).
  144
  145%!  print_html_head(+Out:stream, +Options) is det.
  146%
  147%   Print the =DOCTYPE= line and HTML header.  Options:
  148%
  149%           * header(Bool)
  150%           Only print the header if Bool is not =false=
  151%
  152%           * title(Title)
  153%           Title of the HTML document
  154%
  155%           * stylesheets(List)
  156%           Reference to the CSS style-sheets.
  157%
  158%           * format_comments(Bool)
  159%           If =true= (default), format structured comments.
  160%
  161%           * skin(Closure)
  162%           Called using call(Closure, Where, Out), where Where
  163%           is one of =header= or =footer=.  These calls are made
  164%           just after opening =body= and before closing =body=.
  165
  166print_html_head(Out, Options) :-
  167    option(header(true), Options, true),
  168    !,
  169    option(title(Title), Options, 'Prolog source'),
  170    http_absolute_location(pldoc_resource('pldoc.css'), PlDocCSS, []),
  171    http_absolute_location(pldoc_resource('pllisting.css'), PlListingCSS, []),
  172    option(stylesheets(Sheets), Options, [PlListingCSS, PlDocCSS]),
  173    format(Out, '<!DOCTYPE html', []),
  174    format(Out, '<html>~n', []),
  175    format(Out, '  <head>~n', []),
  176    format(Out, '    <title>~w</title>~n', [Title]),
  177    forall(member(Sheet, Sheets),
  178           format(Out, '    <link rel="stylesheet" type="text/css" href="~w">~n', [Sheet])),
  179    format(Out, '  </head>~n', []),
  180    format(Out, '<body>~n', []),
  181    skin_hook(Out, header, Options).
  182print_html_head(Out, Options) :-
  183    skin_hook(Out, header, Options).
  184
  185print_html_footer(Out, Options) :-
  186    option(header(true), Options, true),
  187    !,
  188    skin_hook(Out, footer, Options),
  189    format(Out, '~N</body>~n', []),
  190    format(Out, '</html>', []).
  191print_html_footer(Out, Options) :-
  192    skin_hook(Out, footer, Options).
  193
  194skin_hook(Out, Where, Options) :-
  195    option(skin(Skin), Options),
  196    call(Skin, Where, Out),
  197    !.
  198skin_hook(_, _, _).
  199
  200
  201%!  html_fragments(+Fragments, +In, +Out, +State, +Options) is det.
  202%
  203%   Copy In to Out, inserting HTML elements using Fragments.
  204
  205html_fragments([], _, _, State, State, _).
  206html_fragments([H|T], In, Out, State0, State, Options) :-
  207    html_fragment(H, In, Out, State0, State1, Options),
  208    html_fragments(T, In, Out, State1, State, Options).
  209
  210%!  html_fragment(+Fragment, +In, +Out,
  211%!                +StateIn, -StateOut, +Options) is det.
  212%
  213%   Print from current position upto the end of Fragment.  First
  214%   clause deals with structured comments.
  215
  216html_fragment(fragment(Start, End, comment(structured), []),
  217              In, Out, State0, [], Options) :-
  218    option(format_comments(true), Options, true),
  219    !,
  220    copy_without_trailing_white_lines(In, Start, Out, State0, State1),
  221    pop_state(State1, Out, In),
  222    Len is End - Start,
  223    read_n_codes(In, Len, Comment),
  224    is_structured_comment(Comment, Prefix),
  225    indented_lines(Comment, Prefix, Lines0),
  226    (   section_comment_header(Lines0, Header, Lines1)
  227    ->  wiki_lines_to_dom(Lines1, [], DOM),
  228        phrase(pldoc_html:html(div(class(comment),
  229                                   [Header|DOM])), Tokens),
  230        print_html(Out, Tokens)
  231    ;   stream_property(In, file_name(File)),
  232        line_count(In, Line),
  233        (   xref_module(File, Module)
  234        ->  true
  235        ;   Module = user
  236        ),
  237        process_modes(Lines0, Module, File:Line, Modes, Args, Lines1),
  238        maplist(assert_seen_mode, Modes),
  239        DOM = [\pred_dt(Modes, pubdef, []), dd(class=defbody, DOM1)],
  240        wiki_lines_to_dom(Lines1, Args, DOM0),
  241        strip_leading_par(DOM0, DOM1),
  242        phrase(pldoc_html:html(DOM), Tokens),               % HACK
  243        format(Out, '<dl class="comment">~n', [Out]),
  244        print_html(Out, Tokens),
  245        format(Out, '</dl>~n', [Out])
  246    ).
  247html_fragment(fragment(Start, End, structured_comment, []),
  248              In, Out, State0, State, _Options) :-
  249    !,
  250    copy_to(In, Start, Out, State0, State1),
  251    line_count(In, StartLine),
  252    Len is End - Start,
  253    read_n_codes(In, Len, Comment),
  254    is_structured_comment(Comment, Prefix),
  255    indented_lines(Comment, Prefix, Lines),
  256    (   section_comment_header(Lines, _Header, _RestSectionLines)
  257    ->  true
  258    ;   stream_property(In, file_name(File)),
  259        line_count(In, Line),
  260        (   xref_module(File, Module)
  261        ->  true
  262        ;   Module = user
  263        ),
  264        process_modes(Lines, Module, File:Line, Modes, _Args, _Lines1),
  265        maplist(mode_anchor(Out), Modes)
  266    ),
  267    start_fragment(structured_comment, In, Out, State1, State2),
  268    copy_codes(Comment, StartLine, Out, State2, State3),
  269    end_fragment(Out, In, State3, State).
  270html_fragment(fragment(Start, End, Class, Sub),
  271              In, Out, State0, State, Options) :-
  272    copy_to(In, Start, Out, State0, State1),
  273    start_fragment(Class, In, Out, State1, State2),
  274    html_fragments(Sub, In, Out, State2, State3, Options),
  275    copy_to(In, End, Out, State3, State4),  % TBD: pop-to?
  276    end_fragment(Out, In, State4, State).
  277
  278start_fragment(atom, In, Out, State0, State) :-
  279    !,
  280    (   peek_code(In, C),
  281        C == 39
  282    ->  start_fragment(quoted_atom, In, Out, State0, State)
  283    ;   State = [nop|State0]
  284    ).
  285start_fragment(Class, _, Out, State, [Push|State]) :-
  286    element(Class, Tag, CSSClass),
  287    !,
  288    Push =.. [Tag,class(CSSClass)],
  289    (   anchor(Class, ID)
  290    ->  format(Out, '<~w id="~w" class="~w">', [Tag, ID, CSSClass])
  291    ;   format(Out, '<~w class="~w">', [Tag, CSSClass])
  292    ).
  293start_fragment(Class, _, Out, State, [span(class(SpanClass))|State]) :-
  294    functor(Class, SpanClass, _),
  295    format(Out, '<span class="~w">', [SpanClass]).
  296
  297end_fragment(_, _, [nop|State], State) :- !.
  298end_fragment(Out, In, [span(class(directive))|State], State) :-
  299    !,
  300    copy_full_stop(In, Out),
  301    format(Out, '</span>', []),
  302    (   peek_code(In, 10),
  303        \+ nonl
  304    ->  assert(nonl)
  305    ;   true
  306    ).
  307end_fragment(Out, _, [Open|State], State) :-
  308    retractall(nonl),
  309    functor(Open, Element, _),
  310    format(Out, '</~w>', [Element]).
  311
  312pop_state([], _, _) :- !.
  313pop_state(State, Out, In) :-
  314    end_fragment(Out, In, State, State1),
  315    pop_state(State1, Out, In).
  316
  317
  318%!  anchor(+Class, -Label) is semidet.
  319%
  320%   True when Label is the =id= we   must  assign to the fragment of
  321%   class Class. This that  the  first   definition  of  a head with
  322%   the id _name/arity_.
  323
  324anchor(head(_, Head), Id) :-
  325    callable(Head),
  326    functor(Head, Name, Arity),
  327    format(atom(Id), '~w/~w', [Name, Arity]),
  328    (   id(Id)
  329    ->  fail
  330    ;   assertz(id(Id))
  331    ).
  332
  333mode_anchor(Out, Mode) :-
  334    mode_anchor_name(Mode, Id),
  335    (   id(Id)
  336    ->  true
  337    ;   format(Out, '<span id="~w"><span>', [Id]),
  338        assertz(id(Id))
  339    ).
  340
  341assert_seen_mode(Mode) :-
  342    mode_anchor_name(Mode, Id),
  343    (   id(Id)
  344    ->  true
  345    ;   assertz(id(Id))
  346    ).
  347
  348%!  copy_to(+In:stream, +End:int, +Out:stream, +State) is det.
  349%
  350%   Copy data from In to Out   upto  character-position End. Inserts
  351%   HTML entities for HTML the reserved characters =|<&>|=. If State
  352%   does not include a =pre= environment,   create  one and skip all
  353%   leading blank lines.
  354
  355copy_to(In, End, Out, State, State) :-
  356    member(pre(_), State),
  357    !,
  358    copy_to(In, End, Out).
  359copy_to(In, End, Out, State, [pre(class(listing))|State]) :-
  360    format(Out, '<pre class="listing">~n', [Out]),
  361    line_count(In, Line0),
  362    read_to(In, End, Codes0),
  363    delete_leading_white_lines(Codes0, Codes, Line0, Line),
  364    assert(lineno),
  365    write_codes(Codes, Line, Out).
  366
  367copy_codes(Codes, Line, Out, State, State) :-
  368    member(pre(_), State),
  369    !,
  370    write_codes(Codes, Line, Out).
  371copy_codes(Codes0, Line0, Out, State, State) :-
  372    format(Out, '<pre class="listing">~n', [Out]),
  373    delete_leading_white_lines(Codes0, Codes, Line0, Line),
  374    assert(lineno),
  375    write_codes(Codes, Line, Out).
  376
  377
  378%!  copy_full_stop(+In, +Out) is det.
  379%
  380%   Copy upto and including the .
  381
  382copy_full_stop(In, Out) :-
  383    get_code(In, C0),
  384    copy_full_stop(C0, In, Out).
  385
  386copy_full_stop(0'., _, Out) :-
  387    !,
  388    put_code(Out, 0'.).
  389copy_full_stop(C, In, Out) :-
  390    put_code(Out, C),
  391    get_code(In, C2),
  392    copy_full_stop(C2, In, Out).
  393
  394
  395%!  delete_leading_white_lines(+CodesIn, -CodesOut, +LineIn, -Line) is det.
  396%
  397%   Delete leading white lines. Used  after structured comments. The
  398%   last two arguments update the  start-line   number  of the <pre>
  399%   block that is normally created.
  400
  401delete_leading_white_lines(Codes0, Codes, Line0, Line) :-
  402    append(LineCodes, [10|Rest], Codes0),
  403    all_spaces(LineCodes),
  404    !,
  405    Line1 is Line0 + 1,
  406    delete_leading_white_lines(Rest, Codes, Line1, Line).
  407delete_leading_white_lines(Codes, Codes, Line, Line).
  408
  409%!  copy_without_trailing_white_lines(+In, +End, +StateIn, -StateOut) is det.
  410%
  411%   Copy input, but skip trailing white-lines. Used to copy the text
  412%   leading to a structured comment.
  413
  414copy_without_trailing_white_lines(In, End, Out, State, State) :-
  415    member(pre(_), State),
  416    !,
  417    line_count(In, Line),
  418    read_to(In, End, Codes0),
  419    delete_trailing_white_lines(Codes0, Codes),
  420    write_codes(Codes, Line, Out).
  421copy_without_trailing_white_lines(In, End, Out, State0, State) :-
  422    copy_to(In, End, Out, State0, State).
  423
  424delete_trailing_white_lines(Codes0, []) :-
  425    all_spaces(Codes0),
  426    !.
  427delete_trailing_white_lines(Codes0, Codes) :-
  428    append(Codes, Tail, [10|Rest], Codes0),
  429    !,
  430    delete_trailing_white_lines(Rest, Tail).
  431delete_trailing_white_lines(Codes, Codes).
  432
  433%!  append(-First, -FirstTail, ?Rest, +List) is nondet.
  434%
  435%   Split List.  First part is the difference-list First-FirstTail.
  436
  437append(T, T, L, L).
  438append([H|T0], Tail, L, [H|T]) :-
  439    append(T0, Tail, L, T).
  440
  441all_spaces([]).
  442all_spaces([H|T]) :-
  443    code_type(H, space),
  444    all_spaces(T).
  445
  446copy_to(In, End, Out) :-
  447    line_count(In, Line),
  448    read_to(In, End, Codes),
  449    (   debugging(htmlsrc)
  450    ->  length(Codes, Count),
  451        debug(htmlsrc, 'Copy ~D chars: ~s', [Count, Codes])
  452    ;   true
  453    ),
  454    write_codes(Codes, Line, Out).
  455
  456read_to(In, End, Codes) :-
  457    character_count(In, Here),
  458    Len is End - Here,
  459    read_n_codes(In, Len, Codes).
  460
  461%!  write_codes(+Codes, +Line, +Out) is det.
  462%
  463%   Write codes that have been read starting at Line.
  464
  465write_codes([], _, _).
  466write_codes([H|T], L0, Out) :-
  467    content_escape(H, Out, L0, L1),
  468    write_codes(T, L1, Out).
  469
  470%!  content_escape(+Code, +Out, +Line0, -Line) is det
  471%
  472%   Write Code to Out, while taking care of.
  473%
  474%           * Use HTML entities for =|<&>|=
  475%           * If a line-no-tag is requested, write it
  476%           * On \n, post a line-no request.  If nonl/0 is set,
  477%             do _not_ emit a newline as it is implied by the
  478%             closed environment.
  479
  480content_escape(_, Out, L, _) :-
  481    (   lineno
  482    ->  retractall(lineno),
  483        write_line_no(L, Out),
  484        fail
  485    ;   fail
  486    ).
  487content_escape(0'\n, Out, L0, L) :-
  488    !,
  489    L is L0 + 1,
  490    (   retract(nonl)
  491    ->  true
  492    ;   nl(Out)
  493    ),
  494    assert(lineno).
  495content_escape(0'<, Out, L, L) :-
  496    !,
  497    format(Out, '&lt;', []).
  498content_escape(0'>, Out, L, L) :-
  499    !,
  500    format(Out, '&gt;', []).
  501content_escape(0'&, Out, L, L) :-
  502    !,
  503    format(Out, '&amp;', []).
  504content_escape(C, Out, L, L) :-
  505    put_code(Out, C).
  506
  507write_line_no(LineNo, Out) :-
  508    format(Out, '<span class="line-no">~|~t~d~5+</span>', [LineNo]).
  509
  510%!  copy_rest(+In, +Out, +StateIn, -StateOut) is det.
  511%
  512%   Copy upto the end of the input In.
  513
  514copy_rest(In, Out, State0, State) :-
  515    copy_to(In, -1, Out, State0, State).
  516
  517%!  read_n_codes(+In, +N, -Codes)
  518%
  519%   Read the next N codes from In as a list of codes. If N < 0, read
  520%   upto the end of stream In.
  521
  522read_n_codes(_, N, Codes) :-
  523    N =< 0,
  524    !,
  525    Codes = [].
  526read_n_codes(In, N, Codes) :-
  527    get_code(In, C0),
  528    read_n_codes(N, C0, In, Codes).
  529
  530read_n_codes(_, -1, _, []) :- !.
  531read_n_codes(1, C, _, [C]) :- !.
  532read_n_codes(N, C, In, [C|T]) :-
  533    get_code(In, C2),
  534    N2 is N - 1,
  535    read_n_codes(N2, C2, In, T).
  536
  537
  538%!  element(+Class, -HTMLElement, -CSSClass) is nondet.
  539%
  540%   Map classified objects to an  HTML   element  and CSS class. The
  541%   actual  clauses  are  created   from    the   1st   argument  of
  542%   prolog_src_style/2.
  543
  544term_expansion(element(_,_,_), Clauses) :-
  545    findall(C, element_clause(C), Clauses).
  546
  547%element_tag(directive, div) :- !.
  548element_tag(_, span).
  549
  550element_clause(element(Term, Tag, CSS)) :-
  551    span_term(Term, CSS),
  552    element_tag(Term, Tag).
  553
  554span_term(Classification, Class) :-
  555    syntax_colour(Classification, _Attributes),
  556    css_class(Classification, Class).
  557
  558css_class(Class, Class) :-
  559    atom(Class),
  560    !.
  561css_class(Term, Class) :-
  562    Term =.. [P1,A|_],
  563    (   var(A)
  564    ->  Class = P1
  565    ;   css_class(A, P2),
  566        atomic_list_concat([P1, -, P2], Class)
  567    ).
  568
  569element(_,_,_).                         % term expanded