:- module(html, [write_html/1,
		 sections_to_normal_html/2
		]).

:- use_module(write_to_atom).

:- ensure_loaded(qtest_header).
:- ensure_loaded(lists).

%%   WARNING: QUOTING IS *NOT* DONE PROPERLY.   THIS HAS SECURITY IMPLICATIONS.

/*  $Id: html.pl,v 1.38 2006/10/22 12:53:03 sandro Exp $
    
    A little toolkit for generating XHTML pages with minimal effort.

    1.  Make a list/term/structure which represents part of the page
    2.  call write_html on that term.

    The represtation rules are illustrated here:

    % single or double quotes work
    write_html("Hello, World!").
    write_html('Hello, World!').

    % xml/html elements look like prolog function terms
    write_html(p('Hello, World!')).

    % ... with variable numbers of arguments
    write_html(p('Hello,', ' World!')).

    % Attributes are arguments using =/2, like this:
    write_html(p(id='p21', 'Hello, World!')).
    write_html(p('Hello, World!', id=p21)). 

    %  @@ this works because "br" is declared HTML.  Ewww.  @@
    write_html(p(id='p21', 'Hello, World!', br, '(please)', class='please')).
    write_html(p(id='p21', 'Hello, World!', br([]), '(...)', class='please')).

    % Invalid elements are suppressed...
    write_html(r('Hello, World!')).          FAIL

    % Arbitrary nesting is fine
    write_html(p(['Hello, World!'])).
    write_html(p([['Hello, World!']])).

    % As an exception, the term 'html' gets a DOCTYPE spit out before it
    write_html(html([head([]), body(p(['Hello, ', em('World!')]))])).

    % \X terms mean run X as a DCG rule and include its output
    [user].
    front :-
       write_html(\f).
    f --> 
      'Hi', 'There', ['You Guys!'].
    
    front.

    % +X works similarly, except it's just run with a last arg
    % to return an HTree.
    % @@

    % @@ more features not documented

    % use key(Key, T) if you want them sorted
    write_html(+findall(key(X, li(int(X))), between(1,10,X))).
    <li>1</li><li>2</li><li>3</li><li>4</li><li>5</li><li>6</li><li>7</li><li>8</li><li>9</li><li>10</li>

     write_html(+forall(between(1,10,X), li(int(X), '-', int(C)),[count(C)])).
     <li>1-1</li><li>2-2</li><li>3-3</li><li>4-4</li><li>5-5</li><li>6-6</li><li>7-7</li><li>8-8</li><li>9-9</li><li>10-10</li>

     X = _G182
     C = 10

     write_html(+findall(key(Key, li(int(X), '-', int(C))),
                        (between(1,10,X), Key is -X),
                        [count(C)]
                      )).
     <li>10-1</li><li>9-2</li><li>8-3</li><li>7-4</li><li>6-5</li><li>5-6</li><li>4-7</li><li>3-8</li><li>2-9</li><li>1-10</li>

     Key = _G321
     X = _G313
     C = 10


    
    

    ISSUES & IDEAS

    - we could use print/portray, but we'd like to have character
      encodings and stuff, I think.

    - we should probably have 90% of the smarts in a DCG; it would
      certainly make testing easier.  (Or we could test via a open-
      stream-to-atom thing; only readable on close.)

*/

% this list comes from 
% http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd

html_element(a).
html_element(abbr).
html_element(acronym).
html_element(address).
html_element(area).
html_element(b).
html_element(base).
html_element(bdo).
html_element(big).
html_element(blockquote).
html_element(body).
html_element(br).
html_element(button).
html_element(caption).
html_element(cite).
html_element(code).
html_element(col).
html_element(colgroup).
html_element(dd).
html_element(del).
html_element(dfn).
html_element(div).
html_element(dl).
html_element(dt).
html_element(em).
html_element(fieldset).
html_element(form).
html_element(h1).
html_element(h2).
html_element(h3).
html_element(h4).
html_element(h5).
html_element(h6).
html_element(head).
html_element(hr).
html_element(html).
html_element(i).
html_element(img).
html_element(input).
html_element(ins).
html_element(kbd).
html_element(label).
html_element(legend).
html_element(li).
html_element(link).
html_element(map).
html_element(meta).
html_element(noscript).
html_element(object).
html_element(ol).
html_element(optgroup).
html_element(option).
html_element(p).
html_element(param).
html_element(pre).
html_element(q).
html_element(samp).
html_element(script).
html_element(select).
html_element(small).
html_element(span).
html_element(strong).
html_element(style).
html_element(sub).
html_element(sup).
html_element(table).
html_element(tbody).
html_element(td).
html_element(textarea).
html_element(tfoot).
html_element(th).
html_element(thead).
html_element(title).
html_element(tr).
html_element(tt).
html_element(ul).
html_element(var).

% These are the elements we'd like to have on their own, indented
% lines in the output XML text.   It's just stylistic preferences.

block(blockquote).
block(body).
block(div).
block(form).
block(h1).
block(h2).
block(h3).
block(h4).
block(h5).
block(h6).
block(head).
block(hr).
block(html).
block(ol).
block(p).
block(script).
block(table).
block(tbody).
block(tr).
block(ul).

block(title).
block(link).

write_html(X) :-
  write_html(X, '').

% prevent havoc on "write_html(_)."
write_html(X, _) :-
   var(X),
   !,
   fail.

write_html([_=_|T], Prefix) :-    % skip over items which are "=" (attrs)
   write_html(T, Prefix).

write_html(\X, Prefix) :-
        !, 
	( call(X, C1, [])
	-> true
	; throw(backslash_eval_failed(X))
	),
	write_html(C1, Prefix).


% special trick which lets us traverss lists and result sets without
% building the resulting HTML structures in memory
write_html(+forall(C1, C2), Prefix) :-
	!,
	expand_goal(C1, CE1),
	forall(CE1,
	       write_html(C2, Prefix)).
write_html(+forall(C1, C2, [count(Count)]), Prefix) :-
	!,
	expand_goal(C1, CE1),
	thread_self(Me),
	atom_concat(Me, ', html:forall counter', Counter),
	flag(Counter, _, 0),
	forall(CE1,
	       (   flag(Counter, TCount, TCount+1),
		   Count is TCount + 1,
		   write_html(C2, Prefix)
	       )
	      ),
	flag(Counter, Count, Count).
write_html(+findall(key(K, O), T), Prefix) :-
	write_html(+findall(key(K, O), T, []), Prefix).
write_html(+findall(key(K, O), T, Options), Prefix) :-
	!,
	expand_goal(T, T1),
	findall(key(K, O, Options), T1, C),
	sort(C, CS),
	write_html(+forall(member(key(_, X, Options), CS),
			   X,
			   Options),
 		   Prefix).
write_html(+findall(O, T), Prefix) :-
	!,
	expand_goal(T, T1),
	findall(O, T1, C),
	forall(member(X, C),
	       write_html(X, Prefix)).

write_html(+if(Goal, Out), Prefix) :-
	!,
	expand_goal(Goal, Goal2),
	(   call(Goal2)
	->  write_html(Out, Prefix)
	;   true
	).
write_html(+ifelse(Goal, True, False), Prefix) :-
	!,
	expand_goal(Goal, Goal2),
	(   call(Goal2)
	->  write_html(True, Prefix)
	;   write_html(False, Prefix)
	).
write_html(+doelse(Expr, OnFail), Prefix) :-
	!,
	expand_goal(Expr, Expr2),
	catch(write_html(Expr2, Prefix),
	      plus_eval_failed(_),
	      write_html(OnFail, Prefix)
	     ).
write_html(+X, Prefix) :-
        !, 
	(   call(X, HTree)
	->  true
	;   throw(plus_eval_failed(X))
	),
	write_html(HTree, Prefix).

write_html(include_static_html(X), _Prefix) :-
	!,
	www_file(X, '.html', FullFileName),
	open(FullFileName, read, Stream, []),
        telling(Telling),
        copy_stream_data(Stream, Telling),
	close(Stream).
write_html(include_file(FullFileName), _Prefix) :-
	!,
	open(FullFileName, read, Stream, []),
        telling(Telling),
        copy_stream_data(Stream, Telling),
	close(Stream).
	
write_html(call_raw(X), _Prefix) :-
	!,
	call(X).
	
write_html({X}, _) :-
	!,
	( expand_goal(X, Y),
	  call(Y)
	; throw(brace_eval_failed(X))
	).

write_html(lang(Tag, Sub), Prefix) :-
	write('<span lang="'),
	write(Tag),
	write('">'),
	write_html(Sub, Prefix),
	write('</span>').
	
write_html(codes(X), _) :-
	% print_message(warning, codes(X)),
	write_codes_html_quoted(X).

write_html(swi_string(X), _) :-
	print_message(warning, swi_str(X)),
	write(X).

/*	
write_html(literal(X), Prefix) :-
   write(X).

write_html(time(X), Prefix) :-
	% might be nice to have your local timezone in your session somewhere
	convert_time(X, TimeStr),
	get_time(Now),
	Ago is Now-X,
	write(TimeStr),
	write(' ('),
	write_html(duration(Ago), Prefix),
	write(' ago').

write_html(duration(X), Prefix) :-
	write(X),
	write(' seconds').
*/

write_html(Tree, Prefix) :-
   %   functor(Tree, Functor, Arity),
   Tree =.. [Functor|ArgList],
   ArgList = [_|_],   % more than one element
   nonvar(Functor),
   html_element(Functor) -> 
       (write_element(Functor, ArgList, Prefix))
    ;
       (nonvar(Functor),
        write('unknown element name: '), 
        write(Functor)).

write_html([int(H)|T], Prefix) :-
   integer(H),
   write(H),
   write_html(T, Prefix).

write_html(int(H), _Prefix) :-
   integer(H),
   write(H).

write_html([float(M,P)|T], Prefix) :-
   format('~*f', [P,M]),
   write_html(T, Prefix).
write_html(float(M,P), _Prefix) :-
   format('~*f', [P,M]).
write_html(format(F,A), _Prefix) :-
   format(F, A).

write_html([format(F,A)|T], Prefix) :-    % do we need this?!?!
   format(F, A),
   write_html(T, Prefix).

% iffy....
write_html([H|T], Prefix) :-
   integer(H),
   % throw(printing_an_integer_is_bad([H|T])),
   put(H),
   write_html(T, Prefix).

write_html([H|T], Prefix) :-
   write_html(H, Prefix),
   write_html(T, Prefix).

write_html([], _).

% mondo experimental hack
%    write_html(wrexec(Expr)) :-
%        call(Expr).   
% eval would be nicer, but.....  how to get return value?

write_html(Atom, _) :-
   atom(Atom),
   write_html_quoted(Atom).

write_html(X, _) :-
   float(X),
   write(X).

write_html(raw(X), _) :-
	write(X).

write_html(Other, _) :-
%   write(user_error, '** Dont know how to write this bit: '),
%   write_term(user_error, Other, [quoted(true)]),
%   writeln(user_error, ''),
%   write(user_error, '(or how to exit gracefully....)'),
	print_message(error, write_html_unknown(Other)),
	write('(error-in-html-write)').
       


/*

   The block stuff isn't perfect -- to do better, I think we'd need to
   switch to a more stateful output routing, perhaps using flag/3, so
   we could collapse newlines.  We want to know if we're on a new line
   already before going to one...    "line-end" not "new-line".
 
*/

write_element(html, CONTENT, Prefix) :-
   writeln('<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"'),
   writeln('    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">'),
   writeln('<html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">'),
   write_html(CONTENT, Prefix),
   writeln('</html>').

write_element(Tag, [], Prefix) :-            % not possible in prolog syntax?
   (block(Tag) -> ( writeln(''),  write(Prefix) ) ; true),
   write('<'), write(Tag), write('/>').

write_element(Tag, [[]], Prefix) :-          % allow for  br([])
   (block(Tag) -> ( writeln(''),  write(Prefix) ) ; true),
   write('<'), write(Tag), write('/>').

write_element(Tag, ArgList, Prefix) :-
   %attributes(Attributes, ArgList),
   %non_attributes(Content, ArgList),
   (block(Tag) -> ( writeln(''),  write(Prefix) ) ; true),
   write('<'), write(Tag), write_attributes(ArgList), write(>),
   concat_atom([Prefix, '  '], P2),
   write_html(ArgList, P2),
   write('</'), write(Tag), write(>),
   (block(Tag) -> ( writeln(''), write(Prefix) ) ; true).

attributes([], []).
attributes([(L=R)|AttrTail], [(L=R)|ArgTail]) :-
   !,
   attributes(AttrTail, ArgTail).
attributes(Skip, [_|ArgTail]) :-
   !,
   attributes(Skip, ArgTail).

% ... or, in a totally different style just for the fun of it ...

non_attributes([], []).
non_attributes(NA, [ArgHead|ArgTail]) :-
   ( ArgHead = ( _=_ ) ) ->
          non_attributes(NA, ArgTail)
      ;   
          (  NA = [ArgHead|Tail],
             non_attributes(Tail, ArgTail)
	  )
   .
   

write_attributes([(L=R)|T]) :-
   !,    % don't just skip if we get a fail...
   write(' '),
%   write(L), write('='), (atom(R) -> write(R); write_value(R)),
   write(L), write('='), write_value(R),
   write_attributes(T).
write_attributes([_|T]) :-    % skip over items with no "="
   write_attributes(T).
write_attributes([]).

write_value(\X) :-
	!,
	callable(X),
	%format(user_error, 'about to call ~k~n', [X]),
	call(X, C1, []),
	%format(user_error, 'call returned ~k~n', [C1]),
        put(34), write_html(C1), put(34)
	%format(user_error, 'wrote ~k~n', [C1])
	.
write_value(V) :-
   atomic(V),
   !, 
   put(34), write_html_quoted(V), put(34).
write_value(V) :-
   V=[_|_],
   !,
   put(34),
   forall(member(E, V),
	  write_html_quoted(E)),
   put(34).
write_value(codes(V)) :-
   put(34), write_codes_html_quoted(V), put(34).
write_value(Other) :-
	throw(write_html_attr_unknown(Other)).	

/*
% here for reference -- it's like 40% slower; dunno why.
write_codes_html_quoted_slow([H|T]) :-
	(   [H]="<"
	->  write('&lt;')
	;   [H]="&"
	->  write('&amp;')
	;   put(H)
	),
	!,
	write_codes_html_quoted_slow(T).
write_codes_html_quoted_slow([]).
*/


write_codes_html_quoted([60|T]) :-
	!,
	write('&lt;'),
	write_codes_html_quoted(T).
write_codes_html_quoted([38|T]) :-
	!,
	write('&amp;'),
	write_codes_html_quoted(T).
write_codes_html_quoted([H|T]) :-
	put(H),
	write_codes_html_quoted(T).
write_codes_html_quoted([]).

write_html_quoted(Atom) :-
	atom_codes(Atom, Codes),
	write_codes_html_quoted(Codes).

	
	
		   
%%  html_cache(Goal, Options, H)
%%  html_cache(Goal, H)
%%
%%  Use like  H=div(foo, bar, +html_cache(+slow_part), baz)
%%
%%  Options:
%%      max_age(+Seconds)     never use cached data older than this
%%      gen(+GenerationGoal)  predicate to find out source-data generation
%%                            number, eg rdf_generation
%%      slack(+Seconds)       data must be this old AND the generation
%%                            have changed before we'll regenerate
%%                            (we don't know when the generation changed
%%                            so we can't do min_stale)
%%
%%   **** NOTE ****    This only caches down one level!  For more
%%   we should really eval down to an atom, with output redirected
%%   (into a memfile, as thread_httpd does)
%%

:- multifile html_cache_data/4.
:- dynamic html_cache_data/4.

html_cache(Goal, H) :-
	html_cache(Goal, [max_age(60)], H).
html_cache(Goal, Options, H) :-
	get_time(Now),
	(   html_cache_data(Goal, H, CreationTime, CreationGeneration),
	    Age is Now - CreationTime,
	    \+ html_stale(Age, Options, CreationGeneration)
	->  true
	;   retractall(html_cache_data(Goal, _, _, _)),
	    call(Goal, H),
	    (   memberchk(gen(GenerationGoal), Options)
	    ->  call(GenerationGoal, Generation)
	    ;   Generation=0
	    ),
	    assert(html_cache_data(Goal, H, Now, Generation))
	).

	    
	    
html_stale(Age, Options, _CreationGeneration) :-
	memberchk(max_age(MaxAge), Options),
	Age > MaxAge.
html_stale(Age, Options, CreationGeneration) :-
	(   memberchk(gen(GenerationGoal), Options)
	->  call(GenerationGoal, Generation),
	    Generation \= CreationGeneration,
	    (   memberchk(slack(Slack), Options)
	    ->  Age > Slack
	    ;   true
	    )
	).

user:qtest :-
	write_to_atom(A, write_html('Hello, World!')),
	A = 'Hello, World!'.





%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%  map_html(+Goal, +In, -Out)
%%
%%  Traverse the HTML tree "In", calling Goal(NodeIn, NodeOut)
%%  on each node in the tree.  Parent nodes are called AFTER
%%  their children are mapped.

map_html(_, [], []).
map_html(Goal, In, Out) :-
	atomic(In),
	!,
	once(call(Goal, In, Out)).
map_html(Goal, [InH|InT], [OutH|OutT]) :-
	!,
	map_html(Goal, InH, OutH),
	map_html(Goal, InT, OutT).
map_html(Goal, In, Out) :-
   In =.. [Functor|ArgList],
   once(ArgList = [_|_]),		% more than one element
   nonvar(Functor),
   (   true %html:html_element(Functor)
   ->  map_html(Goal, ArgList, Mapped),
       Post =.. [Functor | Mapped],  
       once(call(Goal, Post, Out))
    ;  throw(unknown_html_element(Functor))
   ).

	     
%%
%%  Some map_html tricks:
%%

tracemap(X,X) :-
	format('mapping ~q~n', [X]).

% this is an odd trick; it works only because map_html
% maps the children first; the way back up, the "in"
% tree has already had the "section" elements turned
% into "h1", and we can increment them to h2, etc.
number_headers(In, Out) :-
	(   In =.. [ section, Title | Body]
	->  map_html(increment_headers, Body, BodyOut),
	    Out = [ div(class='section', h1(Title), BodyOut) ]
	;   Out = In
	).


% bug: doesn't work if used like h1(foo,bar), but number_headers
% can never generate that, so I don't really care yet.
increment_headers(h1(Content), h2(Content)) :- !.
increment_headers(h2(Content), h3(Content)) :- !.
increment_headers(h3(Content), h4(Content)) :- !.
increment_headers(h4(Content), h5(Content)) :- !.
increment_headers(h5(Content), h6(Content)) :- !.
increment_headers(h6(Content), h6(Content)) :- !.
increment_headers(X,X).

user:qtest:-
	map_html(increment_headers, h1(foo), X),
	X=h2(foo).
user:qtest:-
	map_html(increment_headers, div(span(h2(foo))), X),
	X=div(span(h3(foo))).
user:qtest:-
	map_html(number_headers,
		 section(one, foo, bar, section(two, baz)),
		 X),
	X = [div(class=section, h1(one), [foo, bar, [div(class=section, h2(two), [baz])]])]
	.

sections_to_normal_html(In, Out) :-
	map_html(number_headers, In, Out).


%% sgml_compact(?SGML_Tree, ?HTML_Tree)
%%
%% Convert between the SWI-Prolog XML representation and mine
%%

sgml_compact([], []).
sgml_compact([H|T], [H2|T2]) :-
	sgml_compact(H, H2),
	sgml_compact(T, T2).
sgml_compact(A, A) :- atomic(A).
sgml_compact(element(Tag, Attrs, Kids), H) :-
	var(H),
	sgml_compact(Kids, Kids2),
	append(Attrs, Kids2, Rest),
	(   Rest = []
	->  H =.. [Tag | [[]]]   % compact structure doesn't like empty args
	;   H =.. [Tag | Rest]
	).
sgml_compact(element(Tag, Attrs, Kids), H) :-
	ground(H),
	H =.. [Tag | Rest2],
	sgml_compact(Rest, Rest2),
	html:attributes(Attrs, Rest),
	html:non_attributes(Kids, Rest).

user:qtest :-
	sgml_compact([element(a, [], [])], X),
	X = [a([])].

	
sgml_package_example(
         [ element(html,
             [],
             [ element(head,
           [],
           [ element(title,
               [],
               [ 'Demo'
               ])
           ]),
         element(body,
           [],
           [ '\n',
             element(h1,
               [ align = center
               ],
               [ 'This is a demo'
               ]),
             '\n\n',
             element(p,
               [],
               [ 'Paragraphs in HTML need not be closed.\n'
               ]),
             element(p,
               [],
               [ 'This is called `omitted-tag\' handling.'
               ])
           ])
             ])
         ]
        ).



attribute_term(_=_).
non_attribute_term(X) :- \+ attribute_term(X).

cg(X,Y) :-
	compact_general(X,Y2),
	flatten(Y2, Y).

compact_general([[]], []).
compact_general([[T]], [E]) :-
	!,  
	compact_general([T], [E]).
compact_general([[T]|Ts], [E,Es]) :-
	!,  
	compact_general([T|Ts], [E|Es]).
compact_general([T], [E]) :-
	!, 
	compact_general(T, E).
compact_general([T|Ts], [E|Es]) :-
	!,  % because lists expand via " =.. " below as .(T,Ts)
	compact_general(T, E),
	compact_general(Ts, Es).
compact_general(X, X) :- atomic(X).
compact_general(Term, Element) :-
	Term =.. [Functor|ArgList],
	ArgList = [_|_],	% more than one element
	nonvar(Functor),
	sublist(attribute_term, ArgList, Atts),
	sublist(non_attribute_term, ArgList, Content),
	!,
	compact_general(Content, ConvertedContent),
	Element = element(Functor, Atts, ConvertedContent).


user:qtest :-
	compact_general([a([])], X),
	X = [element(a, [], [])].

user:qtest :-
	compact_general(a(href=x, span(y), b, c(a=b), href2=x2, d), X),
	X = element(a,
		    [href=x, href2=x2],
		    [element(span, [], [y]),
		     b,
		     element(c, [a=b], []),
		     d
		    ]
		   ).
