1		% (c) 2009-2015 Lehrstuhl fuer Softwaretechnik und Programmiersprachen,
2		% Heinrich Heine Universitaet Duesseldorf
3		% This software is licenced under EPL 1.0 (http://www.eclipse.org/org/documents/epl-v10.html)
4
5		/*
6		* This module allows to register predicates as "debugging predicates".
7		* When such a predicate is marked by the prefix operator ~~,
8		* during term expansion, the term is replaced by:
9		* - if remove_debug_calls is true:
10		* one of the term's arguments, namely the one that is marked
11		* by a star (*) during registration
12		* - if remove_debug_calls is false:
13		* only the prefix operator ~~ is removed, leaving the rest
14		* of the term unchanged.
15		*
16		* Example:
17		*
18		* :- register_debugging_call log(-,*).
19		* log(Info,X) :-
20		* print(Info),print(' enter: '),print(X),nl,
21		* call(X),
22		* print(Info),print(' leave: '),print(X),nl.
23		*
24		* :- enable_debugging_calls.
25		* p1 :- ~~log(p1, member(X,[a])).
26		* :- disable_debugging_calls.
27		* p2 :- ~~log(p2, member(X,[a])).
28		*
29		* a call of p1 prints:
30		* p1 enter: member(_123,[a])
31		* p1 leave: member(a,[a])
32		* while a call to p2 prints nothing
33		*
34		*/
35
36		:- module(debugging_calls,[register_debugging_call/1,
37		enable_debugging_calls/0,
38		disable_debugging_calls/0,
39		remove_debugging_calls/4 % called by term expander
40		]).
41
42		:- use_module(library(lists)).
43		:- use_module(library(codesio)).
44
45		:- use_module(module_information,[module_info/2]).
46
47		:- module_info(group,infrastructure).
48		:- module_info(description,'This module provides functionality to specify meta-calls that (like a must-not-fail call) that are short-circuited when compiling production code.').
49
50		:- op(1150, fx, register_debugging_call).
51		:- op(300, fy, ~~).
52
53		:- dynamic remove_debug_calls/0.
54		% remove_debug_calls.
55
56		:- dynamic is_debug_call/3.
57
58		safe_atom_codes(A,C) :-
59		on_exception(error(representation_error(max_atom_length),_),atom_codes(A,C),
60		(print(exception(max_atom_length)),nl,A='???')).
61
62		%avl_term(X) :- var(X),!,fail.
63		%avl_term(avl_set(_)).
64		%avl_term((A,B)):- (avl_term(A) -> true ; avl_term(B)).
65		%avl_term([H|_]) :- avl_term(H).
66
67		remove_debugging_calls(Layout,Term,Layout,Term) :- var(Term),!.
68		%remove_debugging_calls(Layout,nl,Layout,format(' line:~w~n',[Layout])) :- !.
69		% comment in to see nl (newline term_expansion) info with :- prolog_flag(source_info,_,on).
70		remove_debugging_calls(LayoutIn,when(Cond,Body),LayoutOut,ResTerm) :- !,
71		ResTerm = when(Cond,NewBody), % do not expand inside condition
72		(LayoutIn = []
73		-> LayoutBody = [],
74		LayoutOut = []
75		; LayoutIn = [LayoutWhen,LayoutCond,LayoutBody],
76		LayoutOut = [LayoutWhen,LayoutCond,LayoutBodyOut]),
77		remove_debugging_calls(LayoutBody,Body,LayoutBodyOut,NewBody).
78		%remove_debugging_calls(Layout,ground(Term),Layout,Term2) :- !, Term2 = (nonvar(Term),(debugging_calls:avl_term(Term) -> print(ground_check(Term)),nl, trace ; true),ground(Term)). %% comment in to observe ground checks
79		remove_debugging_calls(LayoutIn,Term,Layout2,Term2) :-
80		functor(Term, ~~, 1),
81		arg(1,Term,Term1),
82		nonvar(Term1),!,functor(Term1,Functor,Arity),
83		( LayoutIn = [] -> Layout1 = []
84		; LayoutIn = [_,Layout1]),
85		( is_debug_call(Functor,Arity,CallPos) ->
86		( remove_debug_calls ->
87		safe_arg(CallPos,Term1,TermI),
88		( Layout1 = [] -> LayoutI = []
89		; Layout1 = [_|ArgLayout] ->
90		nth1(CallPos,ArgLayout,LayoutI)),
91		remove_debugging_calls(LayoutI,TermI,Layout2,Term2)
92		; otherwise ->
93		remove_debugging_calls(Layout1,Term1,Layout2,Term2))
94		; otherwise ->
95		write_to_codes(Functor/Arity,M1),
96		append(["encountered unregistered ",M1,
97		" tagged for debugging removal"],M3),
98		safe_atom_codes(Msg1,M3),
99		print_message(error,Msg1),
100		Term2 = Term1
101		).
102		%remove_debugging_calls(LayoutIn,on_exception(E,Call,Code),LayoutOut,Term2) :- !,
103		% LayoutOut = LayoutIn,
104		% print(on_exception(E,Call,Code)),nl,
105		% Term2 = on_exception(E,Call,(format('~n**EXCEPTION = ~w~n~n',[E]),Code)).
106		%remove_debugging_calls(LayoutIn,time_out(Call,TO,Res),LayoutOut,Term2) :- !,
107		% LayoutOut = LayoutIn,
108		% print(time_out(Call,TO,Res)),nl,
109		% Term2 = ((Call = _:C -> true ; Call=C),
110		% functor(C,F,N),format('**TIMEOUT CALL ~w/~w = ~w ms~n',[F,N,TO]),
111		% time_out(Call,TO,Res),
112		% (Res=time_out -> format('**TIMEOUT OCCURED ~w/~w after ~w ms~n',[F,N,TO]) ; true)).
113		remove_debugging_calls(LayoutIn,Term1,LayoutOut,Term2) :-
114		!,functor(Term1,Functor,Arity),
115		functor(Term2,Functor,Arity),
116		( LayoutIn = [] ->
117		LayoutOut = [],
118		remove_debugging_calls_args_nl(1,Arity,Term1,Term2)
119		; LayoutIn = [Pos|Layout1] ->
120		LayoutOut = [Pos|Layout2],
121		remove_debugging_calls_args(Layout1,Term1,Layout2,Term2,1)
122		; otherwise ->
123		LayoutIn = LayoutOut,
124		Term1 = Term2).
125
126		remove_debugging_calls_args([],_,[],_,_).
127		remove_debugging_calls_args([L1|Layout1],Term1,[L2|Layout2],Term2,N) :-
128		safe_arg(N,Term1,In), safe_arg(N,Term2,Out),
129		remove_debugging_calls(L1,In,L2,Out),
130		N2 is N+1,
131		remove_debugging_calls_args(Layout1,Term1,Layout2,Term2,N2).
132
133		safe_arg(N,Term,Arg) :- compound(Term), arg(N,Term,Arg).
134
135		remove_debugging_calls_args_nl(N,Max,_,_) :- N > Max,!.
136		remove_debugging_calls_args_nl(N,Max,Term1,Term2) :-
137		N =< Max,
138		safe_arg(N,Term1,In), safe_arg(N,Term2,Out),
139		remove_debugging_calls([],In,_,Out),
140		N2 is N+1,
141		remove_debugging_calls_args_nl(N2,Max,Term1,Term2).
142
143		register_debugging_call((Call1,Call2)) :-
144		!,register_debugging_call(Call1),
145		register_debugging_call(Call2).
146		register_debugging_call(Call) :-
147		functor(Call,Functor,Arity),
148		Call =.. [_|Args],
149	?	( nth1(Pos,Args,*) ->
150	?	( nth1(NPos,Args,*), NPos \= Pos ->
151		register_error_msg(Call)
152		; otherwise ->
153		retractall(is_debug_call(Functor,Arity,_)),
154		assert(is_debug_call(Functor,Arity,Pos)))
155		; otherwise ->
156		register_error_msg(Call)).
157		register_error_msg(Call) :-
158		write_to_codes(Call,M),
159		append("register_debug_call has wrong argument: ", M, Codes),
160		safe_atom_codes(Msg,Codes),
161		print_message(error,Msg).
162
163
164		enable_debugging_calls :-
165		retractall(remove_debug_calls).
166		disable_debugging_calls :-
167		(remove_debug_calls -> true; assert(remove_debug_calls)).
168
169		/*
170		* This code uses the term_expansion/6 hook, wich
171		* is a multifile-predicate. Due to a bug in SICStus Prolog,
172		* it is not possible to mix uncompiled and compiled code
173		* for such a predicate.
174		* So we always compile the term_expansion hook
175		*/
176		:- prolog_flag(compiling,Pre,compactcode),
177		compile(debugging_calls_te),
178		prolog_flag(compiling,_,Pre).