/* -*- Mode: Prolog -*- */
/** @copyright
  
  This file is part of PrologDoc (http://prologdoc.sourceforge.net/).

  Copyright (C) 2004 by Salvador Fandino (sfandino@@yahoo.com)

  PrologDoc is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation; either version 2 of the License, or
  (at your option) any later version.

  PrologDoc is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with PrologDoc; if not, write to the Free Software
  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

  @/copyright */

:- module(pd_default_callbacks, [ children_cb/5,
				  line_pos_top_cb/5,
				  line_pos_cb/5,
				  args_check_cb/5,
				  pred_args_cb/5,
				  line_to_args_cb/5,
				  open_source_cb/5,
				  close_source_cb/5,
				  auto_doc_cb/5,
				  set_arg_names_cb/5,
				  remap_args_cb/5,
				  make_groups_cb/5,
				  sort_cb/5,
				  flatten_cb/5,
				  assign_id_cb/5,
				  push_current_id_cb/5,
				  pop_current_id_cb/5,
				  register_properties_cb/5,
				  register_entity_cb/5,
				  open_target_file_cb/5,
				  close_target_file_cb/5,
				  print_open_tags_cb/5,
				  print_close_tags_cb/5,
				  print_text_cb/5,
				  resolve_consult_cb/5 ]).

:- use_module(library('prologdoc/pd')).
:- use_module(library('prologdoc/pd_util')).
:- use_module(library('prologdoc/pd_config')).
:- use_module(library('prologdoc/pd_callback')).
:- use_module(library('prologdoc/pd_files')).

/** @pred children_cb(+TreeIn, -TreeOut, Phase, +ArgsIn, -ArgsOut)
  recursively visits element childs and call callbacks
  */
children_cb(t(Name, Args, Childs), t(Name, Args, Childs1), Phase, A, A1) :-
	children_cb1(Childs, Childs1, Phase, A, A1).

children_cb1([], [], _, A, A).
children_cb1([Child|More], [Child1|More1], Phase, A, A1) :-
	call_callbacks(Child, Child1, Phase, A, A2),
	children_cb1(More, More1, Phase, A2, A1).

/** @pred line_pos_top_cb/5
  gets number of lines from top element and pass it as an argument
  */
line_pos_top_cb(Top, Top, _, A, A1) :-
	ea_check(Top, $n_lines=Len),
	la_reset(A, $n_lines=Len, A1).

/** @pred line_pos_cb/5
  sets source file line number where element was found
  */
line_pos_cb(E, E1, _, A, A) :-
	(   ea_select(E, $lines_to_end=LTE, E2),
	    la_get(A, $n_lines=NL)
	->  AL is NL - LTE,
	    ea_append(E2, $at_line=AL, E1)
	;   E1=E ).

check_tag_args([], _).
check_tag_args([H|T], E) :-
	ea_check(E, H=_),
	check_tag_args(T, E).

/** @pred args_check_cb/5
  checks element has all its required arguments
  */
args_check_cb(E, E, _, A, A) :-
	(   is_a(E, Type),
	    tag_args_req(Type, Req)
	->  check_tag_args(Req, E)
	;   true ).

pred_args_cb(t(N, A, C), t(N, A1, C1), _, O, O) :-
	(   select(form=Form, A, A2)
	->  (   Form = Name/Arity
	    ->  C1=C
	    ;	Form =.. [Name|Args],
		length(Args, Arity),
		C1 = [t(mode, [form=Form], [])|C] ),
	    la_set(A2, arity=Arity, A3),
	    la_set(A3, name=Name, A1)
	;   A1=A,
	    C1=C ).

/** @pred line_to_args_cb/5.
  converts $line arg to normal arg 
  */
line_to_args_cb(E, E1, _, A, A) :-
	(   ea_select(E, $line=V, E2)
	->  E = t(Name,_,_),
	    (	is_a(Name, Type),
		tag_arg_line_is_term(Type)
	    ->	atom_to_term(V, Term)
	    ;	Term = V ),
	    ea_prepend(E2, Term, E1)
	;   E1=E ).

set_arg_names(_, [], []) :-
	!.
set_arg_names(_, [K=V|More], [K=V|More1]) :-
	!,
	set_arg_names([], More, More1).
set_arg_names([K|T], [V|More], [K=V|More1]) :-
	!,
	set_arg_names(T, More, More1).
set_arg_names(_, [V|_], _) :-
	throw(invalid_arg(V)).

/** @pred set_arg_names_cb
  adds names to unnamed args as defined by tag_args/2 rules.
  */
set_arg_names_cb(t(Name, Args, C), t(Name, Args1, C), _, A, A) :-
	(   is_a(Name, Type),
	    tag_args(Type, Names)
	;   Names = [] ),
	!,
	set_arg_names(Names, Args, Args1).

user_args([], [], []).
user_args([$H=V|T], [], [$H=V|T]) :- !.
user_args([H|T], [H|A], R) :-
	user_args(T, A, R).

select_elements([], _, [], []).
select_elements([t(N, CA, CC)|T], Type, [t(N, CA, CC)|S], Rest) :-
	is_a(N, Type),
	!,
	select_elements(T, Type, S, Rest).
select_elements([H|T], N, S, [H|Rest]) :-
	select_elements(T, N, S, Rest).

make_groups([], C, C) :-
	!.
make_groups(_, [], []) :-
	!.
make_groups([N/K|T], C, C1) :-
	!,
	select_elements(C, K, S, Rest),
	(   S = []
	->  C1 = C2
	;   C1 = [t(N, [], S)|C2] ),
	make_groups(T, Rest, C2).
make_groups([N], C, [t(N, [], C)]).

/** @pred make_groups_cb/5
  sort and group childs according to tag_groups/2 rules.
  */
make_groups_cb(t(N, A, C), t(N, A, C1), _, O, O) :-
	(   is_a(N, Type),
	    tag_groups(Type, Groups)
	->  make_groups(Groups, C, C1)
	;   C1=C ).

is_any_of([H|T], E) :-
	(   is_a(E, H)
	->  true
	;   is_any_of(T, E) ).

flatten([], _, []).
flatten([t(N, _, C)|T], F, C1) :-
	is_any_of(F, N),
	!,
	append(C, T, C2),
	flatten(C2, F, C1).
flatten([H|T], F, [H|C1]) :-
	flatten(T, F, C1).

/** @pred flatten_cb/5
  flatten element moving child childs to current when they match a tag_flatten/2 rule.
  */
flatten_cb(t(N, A, C), t(N, A, C1), _, O, O) :-
	findall(T, (is_a(N, Type), tag_flatten(Type, T)), F),
	(   F = []
	->  C = C1
	;   flatten(C, F, C1) ).

print_args_as_args([], _).
print_args_as_args([N/A|T], E) :-
	(   ea_get(E, N=V)
	->  format(' ~H="~H"', [A, V])
	;   true ),
	print_args_as_args(T, E).

print_args_as_eles([], _).
print_args_as_eles([N/A|T], E) :-
	(   ea_get(E, N=V)
	->  format('<~H>~H</~H>', [A, V, A])
	;   true ),
	print_args_as_eles(T, E).

print_args_as_text([], _).
print_args_as_text([N|M], E) :-
	(   ea_get(E, N=T)
	->  format('~H', [T])
	;   true  ),
	print_args_as_text(M, E).

/** @pred print_open_tags_cb/5
  print XML opening tag for element. Configured via tag_xml_map/3 and tag_xml_common/3 rules.
  */
print_open_tags_cb(E, E, _, O, O) :-
	tag_xml_map(R, [F|M], _),
	match_tag(R, E),
	!,
	format(F, M).
print_open_tags_cb(E, E, _, O, O) :-
	tag_xml_common(Name/Tag, A2A, A2E, A2T),
	match_tag(t(Name, [], []), E),
	!,
	format('<~H', [Tag]),
	print_args_as_args(A2A, E),
	print_xref_args(E, O),
	format('>'),
	print_args_as_eles(A2E, E),
	print_args_as_text(A2T, E).
print_open_tags_cb(E, E, _, O, O).

rel_to_abs(Rel, O, Abs) :-
	la_get(O, $id($file)=FId),
	ele_ref(file, File, FId, _),
	config(pl_ext, Exts, ['', 'pl']),
	absolute_file_name(Rel, [relative_to(File), extensions(Exts), access(read)], Abs),
	!.

print_xref_args(O, Type, Key, file(Rel), Id, FId) :-
	!,
	rel_to_abs(Rel, O, Abs),
	ele_ref(file, Abs, FId, _),
	ele_ref(Type, Key, Id, FId),
	!.
print_xref_args(_, Type, Key, module(M), Id, FId) :-
	!,
	ele_ref(module, M, _, FId),
	ele_ref(Type, Key, Id, FId),
	!.
print_xref_args(O, Type, Key, _, Id, FId) :-
	la_get(O, $id($file)=FId),
	ele_ref(Type, Key, Id, FId),
	ele_prop(Type, Id, public),
	!.
print_xref_args(O, Type, Key, _, Id, FId) :-
	la_get(O, $id($file)=OId),
	ele_consult(OId, _, _, FId),
	ele_ref(Type, Key, Id, FId),
	ele_prop(Type, Id, public),
	!.
print_xref_args(_, Type, Key, _, Id, FId) :-
	ele_ref(Type, Key, Id, FId),
	ele_prop(Type, Id, public),
	!.
print_xref_args(O, Type, Key, _, Id, FId) :-
	la_get(O, $id($file)=FId),
	ele_ref(Type, Key, Id, FId),
	!.
print_xref_args(O, Type, Key, _, Id, FId) :-
	la_get(O, $id($file)=OId),
	ele_consult(OId, _, _, FId),
	ele_ref(Type, Key, Id, FId),
	!.
print_xref_args(_, Type, Key, _, Id, FId) :-
	ele_ref(Type, Key, Id, FId).

print_xref_args(E, O) :-
	(   tag_xref(M, Type, Key, Where),
	    match_tag(M, E)
	->  (   print_xref_args(O, Type, Key, Where, Id, FId)
	    ->	format(' xfile=~H xref=~H', [FId, Id])
	    ;	true )
	;   true ).

/** @pred print_close_tags_cb/5
  print XML closing tag for element. Configured via tag_xml_map/3 and tag_xml_common/3 rules.
  */
print_close_tags_cb(E, E, _, O, O) :-
	tag_xml_map(R, _, [F|M]),
	match_tag(R, E),
	!,
	format(F, M).
print_close_tags_cb(E, E, _, O, O) :-
	tag_xml_common(Name/Tag, _, _, _),
	match_tag(t(Name, [], []), E),
	!,
	format('</~H>', [Tag]).
print_close_tags_cb(E, E, _, O, O).

/** @pred print_text_cb/5
  print text elements
  */
print_text_cb(text(T), text(T), _, O, O) :-
	format('~H', [T]).

/** @pred open_target_file_cb/5
  create required directories, target file and direct output to it
  */
open_target_file_cb(E, E, _, O, O) :-
	ea_check(E, $target=T),
	file_directory_name(T, Dir),
	make_all_directories(Dir),
	tell(T).

/** @pred close_target_file_cb/5
  close target file
  */
close_target_file_cb(E, E, _, O, O) :-
	told,
	tell(user).

open_source_cb(E, E, _, A, A) :-
	ea_get(E, $abs=File),
	see(File).

close_source_cb(E, E1, _, A, A) :-
	(   match_tag(t(_, [], [t($top, [$module=Module],[])]), E)
	->  ea_reset(E, $module=Module, E1)
	;   E1 = E ),
	seen,
	see(user).
	
auto_doc_cb(E, E1, _, A, A) :-
	read_terms(Ts),
	process_terms(Ts, E, E1).

read_terms(Ts) :-
	(   read_term(Term, [variable_names(V),
			     syntax_errors(dec10),
			     module(pd_read_here)])
	->  bind_vars(V)
	;   Term = end_of_file ),
	(   Term = end_of_file
	->  Ts = []
	;   Ts = [Term|Ts1],
	    read_terms(Ts1) ).

process_terms([], E, E).
process_terms([Term|Q], E, E1) :-
	(   autodoc_term(Term, E, E2, Q, Q1)
	->  process_terms(Q1, E2, E1)
	;   process_terms(Q, E, E1) ).

assign_id_cb(E, E1, _, A, A) :-
	(   tag_id_base(M, AR, Base),
	    match_tag(M, E),
	    las_get(A, AR)
	->  unique_id(Base, Id),
	    ea_reset(E, $id=Id, E1)
	;   E = E1 ).

push_current_id_cb(t(N, Args, C), t(N, Args, C), _, A, A1) :-
	(   la_get(Args, $id=Id)
	->  la_push(A, $id(N)=Id, A1)
	;   A = A1 ).

pop_current_id_cb(t(N, Args, C), t(N, Args, C), _, A, A1) :-
	(   la_get(Args, $id=Id)
	->  la_pop(A, $id(N)=Id, A1)
	;   A = A1 ).

register_properties([], _, _).
register_properties([H|More], Type, Id) :-
	(   H = t(prop, A, _),
	    la_get(A, name=N)
	->  new_prop(Type, Id, N)
	;   true ),
	register_properties(More, Type, Id).

register_properties_cb(E, E, _, A, A) :-
	(   E = t(N, Args, C),
	    la_get(Args, $id=Id)
	->  register_properties(C, N, Id) 
	;   true ).
	    
register_entity_cb(E, E, _, A, A) :-
	(   la_get(A, $id($file)=File),
	    tag_register(M, AR, Type, Name, Id),
	    match_tag(M, E),
	    las_get(A, AR)
	->  new_ref(Type, Name, Id, File)
	;   true ).

resolve_consult_cb(t(N, Args, C), t(N, Args, C), _, A, A) :-
	la_get(A, $id($file)=FId),
	las_get(Args, [$type=T, $name=Name]),
	(   (   T = library
	    ;	T = external_library )
	->  Target = library(Name)
	;   (   ele_ref(file, File, FId, _),
		config(pl_ext, Exts, ['', 'pl']),
		absolute_file_name(Name, [relative_to(File), extensions(Exts), access(read)], Abs)
	    ->	Target = Abs
	    ;	(   T = module
		->  Target = module(Name)
		;   Target = unresolved(Name) ) ) ),
	new_consult(FId, T, Name, Target).

remap_args_cb(t(N, A, C), t(N, A1, C1), _, Q, Q) :-
	(   tag_remap_args(Type, RA, RQ, OA, OC),
	    is_a(N, Type),
	    las_select(A, RA, A2),
	    las_get(Q, RQ)
	->  append(OA, A2, A1),
	    append(OC, C, C1)
	;   A1 = A,
	    C1 = C ).

select_by_type([], _, CT, CT, []).
select_by_type([E|M], T, O, OT, R) :-
	(   E=t(N,_,_),
	    is_a(N, T)
	->  O = [E|O1],
	    select_by_type(M, T, O1, OT, R)
	;   R = [E|R1],
	    select_by_type(M, T, O, OT, R1) ).

order_by_type([], C, C).
order_by_type([T|More], C, O) :-
	select_by_type(C, T, O, OT, Rest),
	order_by_type(More, Rest, OT).

pre_sort([], []).
pre_sort([H|T], [K-H|T1]) :-
	(   tag_sort_key(M, K),
	    match_tag(M, H)
	->  true
	;   K = '' ),
	pre_sort(T, T1).

post_sort([], []).
post_sort([_-H|M], [H|M1]) :-
	post_sort(M, M1).

sort_cb(t(N, A, C), t(N, A, C1), _, Q, Q) :-
	(   tag_order(Type, O),
	    is_a(N, Type)
	->  order_by_type(O, C, C1)
	;   (   tag_sort_childs(Type),
		is_a(N, Type)
	    ->	pre_sort(C, C2),
		keysort(C2, C3),
		post_sort(C3, C1)
	    ;	C = C1 ) ).