/*  Part of XPCE --- The SWI-Prolog GUI toolkit

    Author:        Jan Wielemaker and Anjo Anjewierden
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org/packages/xpce/
    Copyright (C): 2009-2015, VU University Amsterdam

    This program 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.

    This program 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 this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

    As a special exception, if you link this library with other files,
    compiled with a Free Software compiler, to produce an executable, this
    library does not by itself cause the resulting executable to be covered
    by the GNU General Public License. This exception does not however
    invalidate any other reasons why the executable file might be covered by
    the GNU General Public License.
*/

:- module(prolog_trace_exception,
	  [
	  ]).
:- use_module(library(pce)).
:- use_module(library(apply)).
:- use_module(library(persistent_frame)).
:- use_module(library(toolbar)).
:- use_module(library(tabular)).
:- use_module(library(pce_tick_box)).
:- use_module(library(pce_report)).
:- use_module(library(pce_util)).
:- use_module(library(help_message)).

/** <module> Program exception handling

@author	Jan Wielemaker
*/

:- multifile
	prolog:general_exception/2.


:- pce_global(@prolog_exception_window,
	      new(prolog_trace_exception)).

:- dynamic
	exception/4,			% Name, Term, NotCaught, Caught
	installed/1.			% ClauseRef

exception(ex1, error(_, _), true, false).

:- dynamic
	user:prolog_exception_hook/4.

%%	exception_hook(+ExIn, -ExOut, +Frame, +Catcher) is failure.
%
%	Trap exceptions and consider whether or not to start the tracer.

exception_hook(Ex, Ex, _Frame, Catcher) :-
	thread_self(Me),
	thread_property(Me, debug(true)),
	register(Ex),
	exception(_, Ex, NotCaught, Caught), !,
	(   Caught == true
	->  true
	;   Catcher == none,
	    NotCaught == true
	),
	trace, fail.


%%	install_exception_hook
%
%	Make sure our handler is the first of the hook predicate.

install_exception_hook :-
	installed(Ref),
	(   nth_clause(_, I, Ref)
	->  I == 1, !			% Ok, we are the first
	;   retractall(installed(Ref)),
	    erase(Ref),			% Someone before us!
	    fail
	).
install_exception_hook :-
	asserta((user:prolog_exception_hook(Ex, Out, Frame, Catcher) :-
			exception_hook(Ex, Out, Frame, Catcher)), Ref),
	assert(installed(Ref)).


%%	register(Ex) is det.
%
%	Register the new exception with the GUI. We execute this code is
%	the GUI thread as  it  modifyes   the  GUI.  Due to asynchronous
%	execution we need to check  the   an  already  defined exception
%	twice.

register(Ex) :-
	general_exception(Ex, Gen),
	(   defined_exception(Gen)
	->  true
	;   in_pce_thread(register_exception(Gen))
	).


register_exception(Ex) :-
	(   defined_exception(Ex)
	->  true
	;   new_exception(Ex, last)
	).


%%	defined_exception(@Ex) is semidet.
%
%	True if we already have a rule for this exception

defined_exception(Ex) :-
	(   exception(_, Old, _, _),
	    Old =@= Ex
	->  true
	).


%%	general_exception(+ExIn, -ExOut) is det.
%
%	Remove specific aspects of an exception, so   we do not get very
%	long lists of them. This can  be   extended  by  the user and/or
%	libraries  by  adding  rules   for    the   multifile  predicate
%	prolog:general_exception/2.

general_exception(E, E) :-
	var(E), !.
general_exception(E0, E) :-
	prolog:general_exception(E0, E), !.
general_exception(error(E0, _), error(E, _)) :- !,
	general_exception(E0, E).
general_exception(permission_error(Type, Action, _Object),
		  permission_error(Type, Action, _)) :- !.
general_exception(existence_error(Type, _Object),
		  existence_error(Type, _)) :- !.
general_exception(syntax_error(_Message),
		  syntax_error(_)) :- !.
general_exception('$stream'(_), '$stream'(_)) :- !.
general_exception('$socket'(_), '$socket'(_)) :- !.
general_exception(C0, C) :-
	compound(C0), !,
	compound_name_arguments(C0, Name, Args0),
	maplist(general_exception, Args0, Args),
	compound_name_arguments(C, Name, Args).
general_exception(E, E).


%%	new_exception(+Term, +Where) is det.
%%	new_exception(+Term, +NotCaught, +Caught, +Where) is det.
%
%	Add a new exception. If the new exception is a specialization of
%	an already registered exception, copy the properties.

new_exception(Ex, Where) :-
	exception(_, Gen, NotCaught, Caught),
	subsumes_term(Gen, Ex), !,
	new_exception(Ex, NotCaught, Caught, Where).
new_exception(Ex, Where) :-
	(   Ex \= error(_,_)
	->  new_exception(Ex, false, false, Where)
	;   new_exception(Ex, true,  false, Where)
	).

new_exception(Ex, NotCaught, Caught, Where) :-
	(   repeat,
	    gensym(ex, Name),
	    \+ exception(Name, _, _, _)
	->  (   Where == first
	    ->	asserta(exception(Name, Ex, NotCaught, Caught))
	    ;	assertz(exception(Name, Ex, NotCaught, Caught))
	    )
	),
	send(@prolog_exception_window, refresh).


%%	update_exception(+Name, +Term, +NotCaught, +Caught)
%
%	Update  given  exception  in  exception/4.    As  the  order  is
%	maintained by the clauses  we   must  unfortunately  retract and
%	re-assert all clauses. Luckily there are few.

update_exception(Name, Ex, NotCaught, Caught) :-
	T = exception(_,_,_,_),
	findall(T, retract(T), List),
	replace(exception(Name, Ex, NotCaught, Caught), List, New),
	maplist(assertz, New).

replace(E, [H0|T], [E|T]) :-
	arg(1, E, Name),
	arg(1, H0, Name), !.
replace(E, [H|T0], [H|T]) :- !,
	replace(E, T0, T).
replace(_, [], []).


		 /*******************************
		 *	       GUI		*
		 *******************************/

:- pce_begin_class(prolog_trace_exception, persistent_frame,
		   "Configure tracing exceptions").

initialise(F) :->
	send_super(F, initialise, 'Manage exception debugging'),
	send(F, append, new(D, tool_dialog(F))),
	send(F, create_menu),
	send(new(W, dialog), below, D),
	send(W, scrollbars, vertical),
	send(W, ver_stretch, 100),
	send(W, ver_shrink, 100),
	send(W, name, main),
	send(W, display, new(T, prolog_exception_table)),
	send(W, resize_message, message(T, table_width, @arg2?width - 2)),
	send(new(report_dialog), below, W),
	install_exception_hook.

create_menu(F) :->
	get(F, member, tool_dialog, D),
	send(D, append, new(File, popup(file))),
	send(D, append, new(Exceptions, popup(exceptions))),
	send(D, append, new(Debug, popup(debug))),
	send_list(File, append,
		  [ menu_item(exit, message(F, destroy))
		  ]),
	send_list(Exceptions, append,
		  [ menu_item(clear_all,
			      message(F, clear_all),
			      end_group := @on),
		    menu_item('New (error, first)',
			      message(F, new, prolog(error(_,_)))),
		    menu_item('New (general, first)',
			      message(F, new)),
		    menu_item('New (error, last)',
			      message(F, new, prolog(error(_,_)), last)),
		    menu_item('New (general, last)',
			      message(F, new, @default, last))
		  ]),
	send_list(Debug, append,
		  [ menu_item(debug_mode,
			      message(F, debug_mode, @on)),
		    menu_item(nodebug_mode,
			      message(F, debug_mode, @off))
		  ]).


table(F, Table:tabular) :<-
	"Get the table"::
	get(F, member, main, W),
	get(W, member, prolog_exception_table, Table).

new(_F, Term:[prolog], Where0:[{first,last}]) :->
	"Define new exception"::
	default(Where0, first, Where),
	(   Term == @default
	->  new_exception(_, Where)
	;   new_exception(Term, Where)
	).

clear_all(F) :->
	"Remove all exceptions"::
	retractall(exception(_,_,_,_)),
	send(F, refresh).

refresh(F) :->
	get(F, table, T),
	send(T, refresh).

debug_mode(_F, OnOff:bool) :->
	"Switch debug mode on/off"::
	(   OnOff == @on
	->  in_pce_thread(tdebug)
	;   in_pce_thread(tnodebug)
	).

:- pce_end_class(prolog_trace_exception).


:- pce_begin_class(prolog_exception_table, tabular,
		   "Show Prolog exceptions").

initialise(T) :->
	send_super(T, initialise),
	send(T, rules, all),
	send(T, cell_spacing, -1),
	BG = (background := khaki1),
	send(T, append, 'Exception',        bold, left,   BG),
	send(T, append, 'Trace not caught', bold, center, BG),
	send(T, append, 'Trace always',     bold, center, BG),
	send(T, next_row),
	send(T, append_error, ex1, error(_,_), true, false), % one for proper layout
	send(T, compute),
	set_column_rubber(T, 1, 100, 100, @off),
	set_column_rubber(T, 2, 0, 0, @on),
	set_column_rubber(T, 3, 0, 0, @on),
	set_column_rubber(T, 4, 0, 0, @on),
	send(T, refresh).

set_column_rubber(T, N, Stretch, Shrink, Fixed) :-
	get(T, column, N, C),
	send(C, rubber, new(R, rubber(1, Stretch, Shrink))),
	(   Fixed == @on
	->  send(C, fixed, @on),
	    send(R, natural, C?width)
	;   true
	).

clear(T) :->
	send(T, delete_rows, 2, @default).

refresh(T) :->
	send(T, clear),
	forall(exception(Name, Error, NotCaught, Caught),
	       send(T, append_error, Name, Error, NotCaught, Caught)),
	install_exception_hook.		% make sure!


append_error(T, Name:name, Error:prolog, Trace:[bool], WhenCaught:[bool]) :->
	get(T, current, point(_, RowN)),
	get(T, row, RowN, @on, Row),
	send(Row, name, Name),
	send(T, append, new(TI, prolog_term_item(exception, Error))),
	send(T, append, new(Tr, tick_box(trace_not_caught, Trace)),
	     halign := center, valign := bottom),
	send(T, append, new(Ca, tick_box(trace_caught, WhenCaught)),
	     halign := center, valign := bottom),
	new(D, figure),
	send(D, format, new(Fmt, format(vertical, 1, @on))),
	send(Fmt, row_sep, 1),
	send_list(D, display,
		  [ pte_img_button(up),
		    pte_img_button(down),
		    pte_img_button(delete)
		  ]),
	send(T, append, D, valign := center),
	send_list([TI, Tr, Ca], show_label, @off),
	send_list([Tr, Ca], auto_align, @off),
	send(TI, message, message(T, modify, Tr, @arg1)),
	send(Tr, message, message(T, modify, Tr, @arg1)),
	send(Ca, message, message(T, modify, Ca, @arg1)),
	send(T, next_row),
	(   get(T, window, W)
	->  send(W, keyboard_focus, TI)
	;   true
	).

:- pce_group(actions).

modify(T, TB:tick_box, _Val:any) :->
	"One of the tick-boxes changed"::
	get(TB, layout_interface, Cell),
	get(Cell, row, RowI),
	get(T, row, RowI, Row),
	get(Cell, table, Table),
	get(Table, cell, 1, RowI, TermCell),
	get(Table, cell, 2, RowI, NotCaughtCell),
	get(Table, cell, 3, RowI, CaughtCell),
	get(TermCell?image, selection, Exception),
	get(NotCaughtCell?image, selection, PceNotCaught),
	get(CaughtCell?image, selection, PceCaught),
	prolog_pce_bool(NotCaught, PceNotCaught),
	prolog_pce_bool(Caught, PceCaught),
	get(Row, name, Name),
	update_exception(Name, Exception, NotCaught, Caught).

alter(T, RowI:int, Action:{up,down,delete}) :->
	get(T, row, RowI, Row),
	get(Row, name, Name),
	E = exception(_,_,_,_),
	findall(E, E, List),
	(   Action == delete
	->  select(exception(Name, _, _, _), List, New)
	;   Action == up
	->  up(Name, List, New)
	;   Action == down
	->  down(Name, List, New)
	),
	retractall(exception(_,_,_,_)),
	maplist(assert, New),
	send(T, refresh).

up(Name, [E0,E1|T], [E1, E0|T]) :-
	arg(1, E1, Name), !.
up(Name, [H|T0], [H|T]) :- !,
	up(Name, T0, T).
up(_, [], []).

down(Name, [E0,E1|T], [E1, E0|T]) :-
	arg(1, E0, Name), !.
down(Name, [H|T0], [H|T]) :- !,
	down(Name, T0, T).
down(_, [], []).


prolog_pce_bool(true, @on).
prolog_pce_bool(false, @off).

:- pce_end_class(prolog_exception_table).


resource(up,     image, image('16x16/up.xpm')).
resource(down,   image, image('16x16/down.xpm')).
resource(delete, image, image('16x16/delete.xpm')).

:- pce_begin_class(pte_img_button, button).

initialise(B, Name:name) :->
	send_super(B, initialise, Name,
		   message(B?device?device, alter, B?row, Name)),
	send(B, label, image(resource(Name))),
	send(B, help_message, tag, Name?capitalise).

row(B, Row:int) :<-
	"Row in table"::
	get(B?device?layout_interface, row, Row).

:- pce_end_class(pte_img_button).


		 /*******************************
		 *	    TERM ITEM		*
		 *******************************/

:- pce_begin_class(prolog_term_item, text_item,
		   "Item for entering a Prolog term").

initialise(TI, Name:name, Term:prolog, Message:[code]*) :->
	send_super(TI, initialise, Name, @default, Message),
	send(TI, selection, Term).

selection(TI, Term:prolog) :->
	send(TI, slot, selection, prolog(Term)),
	\+ \+ ( numbervars(Term, 0, _, [singletons(true)]),
		format(string(S), '~W', [Term, [ quoted(true),
						 numbervars(true)
					       ]]),
		send(TI, string, S)).

selection(TI, Term:prolog) :<-
	get(TI, slot, selection, Term).


typed(TI,  Ev:'event|event_id') :->
	"Update related term"::
	send_super(TI, typed, Ev),
	get(TI, string, S),
	object(S, string(Text)),
	(   catch(atom_to_term(Text, Term, _), _, fail)
	->  send(TI?value_text, colour, black),
	    (   get(TI, slot, selection, Old),
	        Old =@= Term
	    ->	true
	    ;	send(TI, slot, selection, prolog(Term)),
		(   get(TI, message, Msg),
		    send(Msg, instance_of, code)
		->  send(Msg, forward, prolog(Term))
		;   true
		)
	    )
	;   send(TI?value_text, colour, red)
	).

:- pce_end_class(prolog_term_item).
