%------------------------------------------------------------------------------%
% Copyright (C) 1999-2001 INRIA/INSA de Rennes/IFSIC.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file License in the Morphine distribution.
%
% Author : Erwan Jahier <jahier@irisa.fr>
%
% This files contains various types declarations concerning the event 
% attributes. Those types are used both in forward_move.op and 
% current_slots.op.


%------------------------------------------------------------------------------%
opium_type(
	name		: is_port,
	implementation	: is_port_Op,
	message		:
"Succeeds for a Mercury Port. Mercury ports are call (or 'CALL'), \
exit (or 'EXIT'), fail (or 'FAIL'), redo (or 'REDO'), then (or 'THEN'), \
else (or 'ELSE'), disj (or 'DISJ'), switch (or 'SWITCH' or 'SWTC'), \
first (or 'FIRST' or 'FRST'), later (or 'LATER' or 'LATR'), \
exception (or 'EXCP' or 'EXCEPTION'). \
").
is_port_Op(Port) :-
	is_list_of_ports_Op([Port]).

%------------------------------------------------------------------------------%
opium_type(
	name		: is_port_or_var,
	implementation	: is_port_or_var_Op,
	message		:
"Succeeds for a Mercury port or a variable (See `is_port/1').\
").
is_port_or_var_Op(X) :-
	var(X), !
    ;
	is_port(X).

%------------------------------------------------------------------------------%
opium_type(
	name		: is_list_of_ports,
	implementation	: is_list_of_ports_Op,
	message		:
"Succeeds for a sublist of ['CALL', 'EXIT', 'REDO', 'FAIL', 'THEN',\
 'ELSE', 'DISJ', 'SWITCH', 'SWTC', 'FIRST', 'FRST', 'LATER', 'LATR', 'EXCP', \
'EXCEPTION', \
call, exit, fail, redo, cond, then, else, disj, switch, first, later, exception, \
neg_enter, neg_success, neg_failure].\
").

is_list_of_ports_Op(List) :-
	list_of_mercury_ports(ListMercPorts),
	is_sublist(List, ListMercPorts).

is_sublist([], _).
is_sublist([Term | Tail], L2) :-
	member(Term, L2),
	is_sublist(Tail, L2).

list_of_mercury_ports([
	'CALL', 'EXIT', 'FAIL', 'REDO', 'THEN', 'ELSE', 'DISJ', 'SWITCH', 
	'SWTC', 'FIRST', 'FRST', 'LATER', 'LATR', 'EXCP', 'EXCEPTION', 
	call, exit, fail, redo, cond, then, else, disj, switch, first, later, 
	exception, neg_enter, neg_success, neg_failure]).


%------------------------------------------------------------------------------%
opium_type(
	name		: is_port_attribute,
	implementation	: is_port_attribute_Op,
	message		:
"Succeeds for a port, a negated port (not('CALL')), a list of \
ports, '-' or a variable.\
").


is_port_attribute_Op(Attribute) :-
	Attribute == '-'
    ;
	free(Attribute), !
    ;
	is_port(Attribute)
    ;
	Attribute = not(AttributeNeg),
	is_port(AttributeNeg)
    ;
	Attribute = \+(AttributeNeg),
	is_port(AttributeNeg)
    ;
	is_list_of_ports(Attribute)
    .

%------------------------------------------------------------------------------%
opium_type(
	name		: is_goal_path,
	implementation	: is_goal_path_Op,
	message		: 
"Succeeds for list of atoms of the form '?','e', 't', '~', 'q', \
'ci', 'si', 'di' where i is an integer > 0."
	).


is_goal_path_Op([X|Xs]) :-
	is_valid_path(X),
	is_goal_path_Op(Xs).

is_goal_path_Op([]).

is_valid_path('?').
is_valid_path(e).
is_valid_path(t).
is_valid_path(q).
is_valid_path('~').
is_valid_path(X) :-
	atom_string(X, Xstr),
	append_strings("d", IntStr, Xstr), 
	atom_string(Int, IntStr),
	integer_atom(_, Int).
is_valid_path(X) :-
	atom_string(X, Xstr),
	append_strings("c", IntStr, Xstr), 
	atom_string(Int, IntStr),
	integer_atom(_, Int).
is_valid_path(X) :-
	atom_string(X, Xstr),
	append_strings("s", IntStr, Xstr), 
	atom_string(Int, IntStr),
	integer_atom(_, Int).


%------------------------------------------------------------------------------%
opium_type(
	name		: is_goal_path_or_var,
	implementation	: is_goal_path_or_var_Op,
	message		:
"Succeeds for a Mercury goal path or a variable (See `is_goal_path/1').").

is_goal_path_or_var_Op(X) :-
	var(X), !
    ;
	is_goal_path(X).


%------------------------------------------------------------------------------%
% Should we need a Opium declaration for this one ?
% :- pred is_list_of_paths(attribute).
% :- mode is_list_of_paths(in) is semidet.
is_list_of_goal_paths([X|Xs]) :-
	is_goal_path(X),
	is_list_of_goal_paths(Xs).

is_list_of_goal_paths([]).

%------------------------------------------------------------------------------%
opium_type(
	name		: is_goal_path_attribute,
	implementation	: is_goal_path_attribute_Op,
	message		:
"Succeeds for a goal path, a negated goal path, a list of goal path, '-' or \
a variable.").


is_goal_path_attribute_Op(Attribute) :-
	Attribute == '-'
    ;
	free(Attribute), !
    ;
	is_goal_path(Attribute)
    ;
	Attribute = not(AttributeNeg),
	is_goal_path(AttributeNeg)
    ;
	Attribute = \+(AttributeNeg),
	is_goal_path(AttributeNeg)
    ;
	is_list_of_goal_paths(Attribute)
    .


%------------------------------------------------------------------------------%
opium_type(
	name		: is_atom_attribute,
	implementation	: is_atom_attribute_Op,
	message		:
"Succeeds for an atom, a negated atoms, a list of atom, a variable \
or '-'. It is intended to check `proc_name' `def_module' and \
`decl_module' attributes.\
").


is_atom_attribute_Op(Attribute) :-
	Attribute == '-'
    ;
	free(Attribute), !
    ;
	atom(Attribute), !
    ;
	Attribute = not(AttributeNeg),
	atom(AttributeNeg), !
    ;
	Attribute = \+(AttributeNeg),
	atom(AttributeNeg), !
    ;
	is_list_of_atoms(Attribute)
    .

%------------------------------------------------------------------------------%
opium_type(
	name		: is_proc_type,
	implementation	: is_proc_type_Op,
	message		:
"Succeeds for the atoms `predicate' and `function'.").

is_proc_type_Op(X) :-
	member(X, [predicate, function]).


%------------------------------------------------------------------------------%
opium_type(
	name		: is_proc_type_attribute,
	implementation	: is_proc_type_attribute_Op,
	message		:
"Succeeds for pred or func, not(pred) or not(func), \
a list of atoms pred or func, '-' or a variable.").


is_proc_type_attribute_Op(Attribute) :-
	Attribute == '-'
    ;
	free(Attribute), !
    ;
	member(Attribute, [predicate, function]), !
    ;
	Attribute = not(AttributeNeg),
	member(AttributeNeg, [predicate, function]), !
    ;
	Attribute = \+(AttributeNeg),
	member(Attribute, [predicate, function]), !
    ;
	subtract(Attribute, [predicate, function], [])
    .


%------------------------------------------------------------------------------%
opium_type(
	name		: is_det_marker,
	implementation	: is_det_marker_Op,
	message		:
"Succeeds for a Mercury determinism marker. Mercury determinism are \
det (or 'DET'), semidet (or 'SEMI'), nondet (or 'NON'), multidet (or 'MUL'), \
cc_nondet (or 'CCNON'), cc_multidet (or 'CCMUL'), failure (or 'FAIL') and \
erroneous (or 'ERR'). \
").
is_det_marker_Op(Det) :-
	is_list_of_dets_Op([Det]).

%------------------------------------------------------------------------------%
opium_type(
	name		: is_det_marker_or_var,
	implementation	: is_det_marker_or_var_Op,
	message		:
"Succeeds for a Mercury determinism markers or a variable.\
").

is_det_marker_or_var_Op(X) :-
	var(X), !
    ;
	is_det_marker(X).

%------------------------------------------------------------------------------%
opium_type(
	name		: is_list_of_dets,
	implementation	: is_list_of_dets_Op,
	message		:
"Succeeds for a sublist of [det, semidet, nondet, multidet,\
 cc_nondet, cc_multidet, failure, erroneous, 'DET', 'SEMI', 'NON', 'MUL', \
'ERR', 'FAIL', 'CCNON', 'CCMUL'] \
(the determinism markers in capital letters are the ones used in mdb, the \
internal Mercury debugger).\
").

is_list_of_dets_Op(List) :-
	list_of_mercury_dets(ListMercDets),
	is_sublist(List, ListMercDets).


list_of_mercury_dets([det, semidet, nondet, multidet, cc_nondet, 
	cc_multidet, failure, erroneous, 'DET', 'SEMI', 'NON', 'MUL', 
	'ERR', 'FAIL', 'CCNON', 'CCMUL']).

%------------------------------------------------------------------------------%
opium_type(
	name		: is_det_marker_attribute,
	implementation	: is_det_marker_attribute_Op,
	message		:
"Succeeds for a Mercury determinism marker, a negated  determinism \
(not(nondet)), a list of determinism markers, '-' or a variable.\
").


is_det_marker_attribute_Op(Attribute) :-
	Attribute == '-'
    ;
	free(Attribute), !
    ;
	is_det_marker(Attribute), !
    ;
	Attribute = not(AttributeNeg),
	is_det_marker(AttributeNeg), !
    ;
	Attribute = \+(AttributeNeg),
	is_det_marker(AttributeNeg), !
    ;
	is_list_of_dets(Attribute)
    .


%------------------------------------------------------------------------------%
opium_type(
	name		: is_proc,
	implementation	: is_proc_Op,
	message		:

"Succeeds for terms of the form \
`[ProcType+][Module:]ProcName[/Arity][-ModeNum]' where terms betwenn square \
bracquets are optional, `ProcType' has type `is_proc_type_attribute/1', \
`Module' and `ProcName' have type `is_atom_attribute/1', `Arity' and `ModeNum' \
have `type is_integer_attribute/1'.").


is_proc_Op(Proc) :-
	(
		Proc = P,
		is_atom_attribute(P),
		!
	;	
		Proc = (PT->P),
		is_proc_type_attribute(PT),
		is_atom_attribute(P),
		!
	;
		Proc = M:P,
		is_atom_attribute(M),
		is_atom_attribute(P),
		!
	;
		Proc = P/A,
		is_atom_attribute(P),
		is_integer_attribute(A),
		!
	;
		Proc = P-MN,
		is_atom_attribute(P),
		is_integer_attribute(MN),
		!
	;
		Proc = (P/A-MN),
		is_atom_attribute(P),
		is_integer_attribute(A),
		is_integer_attribute(MN),
		!
	;
		Proc = M:(P-MN),
		is_atom_attribute(M),
		is_atom_attribute(P),
		is_integer_attribute(MN),
		!
	;
		Proc = M:(P/A),
		is_atom_attribute(M),
		is_atom_attribute(P),
		is_integer_attribute(A),
		!
	;
		Proc = (PT->(P-MN)),
		is_proc_type_attribute(PT),
		is_atom_attribute(P),
		is_integer_attribute(MN),
		!
	;
		Proc = (PT->(P/A)),
		is_proc_type_attribute(PT),
		is_atom_attribute(P),
		is_integer_attribute(A),
		!
	;
		Proc = (PT->M:P),
		is_proc_type_attribute(PT),
		is_atom_attribute(M),
		is_atom_attribute(P),
		!
	;
		Proc = M:(P/A-MN),
		is_atom_attribute(M),
		is_atom_attribute(P),
		is_integer_attribute(A),
		is_integer_attribute(MN),
		!
	;
		Proc = (PT->(P/A-MN)),
		is_proc_type_attribute(PT),
		is_atom_attribute(P),
		is_integer_attribute(A),
		is_integer_attribute(MN),
		!
	;
		Proc = (PT->M:(P-MN)),
		is_proc_type_attribute(PT),
		is_atom_attribute(M),
		is_atom_attribute(P),
		is_integer_attribute(MN),
		!
	;
		Proc = (PT->M:(P/A)),
		is_proc_type_attribute(PT),
		is_atom_attribute(M),
		is_atom_attribute(P),
		is_integer_attribute(A),
		!
	;
		Proc = (PT->M:(P/A-MN)),
		is_proc_type_attribute(PT),
		is_atom_attribute(M),
		is_atom_attribute(P),
		is_integer_attribute(A),
		is_integer_attribute(MN)
	).

is_proc_Op(-) :-
	!.

%------------------------------------------------------------------------------%
opium_type(
	name		: is_proc_or_var,
	implementation	: is_proc_or_var_Op,
	message		:
"Succeeds for a Mercury procedure or a variable.\
").
is_proc_or_var_Op(X) :-
	var(X), !
    ;
	is_proc(X).

%------------------------------------------------------------------------------%
opium_type(
	name		: is_arg_attribute,
	implementation	: is_arg_attribute_Op,
	message		:
"For the time being, you can't perform filtering on arguments, i.e., you can \
only have variables or '-' for that attribute.\
").
is_arg_attribute_Op(Attribute) :-
	free(Attribute) ; Attribute == '-'.


%------------------------------------------------------------------------------%
opium_type(
	name		: is_integer_attribute,
	implementation	: is_integer_attribute_Op,
	message		:
"Succeeds for an integer, a negated integer (not 6), a list of \
 integers ([3, 5, 9]), an interval ('3..11'), a variable or '-'.\
"
	).
is_integer_attribute_Op(Attribute) :-
	Attribute == '-', 
	!
    ;
	free(Attribute), 
	!
    ;
	integer(Attribute), 
	!
    ;
	Attribute = not(AttributeNeg),
	integer(AttributeNeg), 
	!
    ;
	Attribute = \+(AttributeNeg),
	integer(AttributeNeg), 
	!
    ;
	is_list_of_integers(Attribute), 
	!
    ;
	Attribute = Bottom .. Up,
	integer(Bottom),
	integer(Up),
	Bottom =< Up
    .

%:- pred is_list_of_integers(list(integer)).
%:- mode is_list_of_integers(in) is semidet.
is_list_of_integers([]).
is_list_of_integers([X | Xs]) :-
	integer(X),
	is_list_of_integers(Xs).


%------------------------------------------------------------------------------%
opium_type(
	name		: is_string_attribute,
	implementation	: is_string_attribute_Op,
	message		:
"Succeeds for a string, a negated string (not \"foo\"), a list of \
 strings, a variable or '-'.\
").
is_string_attribute_Op(Attribute) :-
	Attribute == '-'
    ;
	free(Attribute), !
    ;
	string(Attribute)
    ;
	Attribute = not(AttributeNeg),
	string(AttributeNeg)
    ;
	Attribute = \+(AttributeNeg),
	string(AttributeNeg)
    ;
	is_list_of_strings(Attribute)
    .


%:- pred is_list_of_strings(list(string)).
%:- mode is_list_of_strings(in) is semidet.
is_list_of_strings([]).
is_list_of_strings([X | Xs]) :-
	string(X),
	is_list_of_strings(Xs).


%------------------------------------------------------------------------------%
opium_command(
	name		: list_attribute_aliases,
	arg_list	: [],
	arg_type_list	: [],
	abbrev		: laa,
	interface	: hidden,
	command_type	: opium,
	implementation	: list_attribute_aliases_op,
	parameters	: [],
	message		:
"Lists the available aliases for the different Mercury event attributes \
(`fget/1' and `current/1').").

list_attribute_aliases_op :-
	findall(X, is_alias_for(chrono, X), Lchrono),
	findall(X, is_alias_for(call, X), Lcall),
	findall(X, is_alias_for(depth, X), Ldepth),
	findall(X, is_alias_for(port, X), Lport),
	findall(X, is_alias_for(proc_type, X), LPredOrFunc),
	findall(X, is_alias_for(decl_module, X), Ldeclmodule),
	findall(X, is_alias_for(def_module, X), Ldefmodule),
	findall(X, is_alias_for(name, X), Lname),
	findall(X, is_alias_for(arity, X), Larity),
	findall(X, is_alias_for(mode_number, X), Lmode_number),
	findall(X, is_alias_for(proc, X), Lproc),
	findall(X, is_alias_for(det, X), Ldet),
	findall(X, is_alias_for(goal_path, X), Lgoal_path),
	findall(X, is_alias_for(args, X), Largs),
	findall(X, is_alias_for(arg_names, X), LArgsName),
	findall(X, is_alias_for(arg_types, X), LArgsType),
	findall(X, is_alias_for(vars, X), LVars),
	findall(X, is_alias_for(var_names_and_types, X), Lvar_names_and_types),
	findall(X, is_alias_for(local_vars, X), Lother),
	findall(X, is_alias_for(stack, X), Lstack),
	printf("List of attribute aliases for fget/1 and current/1:\n",[]),
	printf("%19s: %w\n", [chrono, Lchrono]),
	printf("%19s: %w\n", [call, Lcall]),
	printf("%19s: %w\n", [depth, Ldepth]),
	printf("%19s: %w\n", [port, Lport]),
	printf("%19s: %w\n", [proc_type, LPredOrFunc]),
	printf("%19s: %w\n", [def_module, Ldefmodule]),
	printf("%19s: %w\n", [decl_module, Ldeclmodule]),
	printf("%19s: %w\n", [name, Lname]),
	printf("%19s: %w\n", [arity, Larity]),
	printf("%19s: %w\n", [mode_number, Lmode_number]),
	printf("%19s: %w\n", [proc, Lproc]),
	printf("%19s: %w\n", [det, Ldet]),
	printf("%19s: %w\n", [goal_path, Lgoal_path]),

	printf("\nList of attribute aliases for current/1 only:\n",[]),
	printf("%19s: %w\n", [args, Largs]),
	printf("%19s: %w\n", [arg_names, LArgsName]),
	printf("%19s: %w\n", [arg_types, LArgsType]),
	printf("%19s: %w\n", [vars, LVars]),
	printf("%19s: %w\n", [var_names_and_types, Lvar_names_and_types]),
	printf("%19s: %w\n", [local_vars, Lother]),
	printf("%19s: %w\n", [stack, Lstack]).

%------------------------------------------------------------------------------%
% opium_primitive(
% 	name		: is_alias_for,
% 	arg_list	: [AttributeName, Alias],
% 	arg_type_list	: [atom, atom],
% 	implementation	: is_alias_for_Op,
% 	message		:
% "Succeeds if Alias is an alias for the attribute AttributeName. The aliases \
% for all the attributes can be listed with list_attribute_aliases/0 command.
% "
%  	).

% This is used for both fget/1 and current/1 command.
is_alias_for(chrono, chrono).
is_alias_for(chrono, c).

is_alias_for(call, call).
is_alias_for(call, ca).
is_alias_for(call, cl).

is_alias_for(depth, depth).
is_alias_for(depth, d).

is_alias_for(port, port).
is_alias_for(port, p).

is_alias_for(proc, procedure).
is_alias_for(proc, proc).

is_alias_for(name, procedure_name).
is_alias_for(name, proc_name).
is_alias_for(name, name).
is_alias_for(name, n).

is_alias_for(proc_type, proc_type).
is_alias_for(proc_type, pred_or_func).
is_alias_for(proc_type, pof).

is_alias_for(decl_module, decl_module).
is_alias_for(decl_module, decl_mod).
is_alias_for(decl_module, dlm).

is_alias_for(def_module, def_module).
is_alias_for(def_module, def_mod).
is_alias_for(def_module, dfm).

is_alias_for(arity, arity).
is_alias_for(arity, ar).

is_alias_for(mode_number, mode_number).
is_alias_for(mode_number, mode_num).
is_alias_for(mode_number, mn).

is_alias_for(det, determinism).
is_alias_for(det, deter).
is_alias_for(det, det).

is_alias_for(goal_path, goal_path).
is_alias_for(goal_path, gp).

is_alias_for(line_number, line_number).
is_alias_for(line_number, ln).


% XXX Those ones are not hanled in fget yet.
is_alias_for(args, arguments).
is_alias_for(args, args).
is_alias_for(args, arg).
is_alias_for(args, a).

is_alias_for(arg_names, arg_names).
is_alias_for(arg_names, an).

is_alias_for(arg_types, arg_types).
is_alias_for(arg_types, types).
is_alias_for(arg_types, type).
is_alias_for(arg_types, at).

is_alias_for(vars, vars).

is_alias_for(var_names_and_types, var_names_and_types).
is_alias_for(var_names_and_types, vnt).

is_alias_for(local_vars, local_vars).
is_alias_for(local_vars, local_var).
is_alias_for(local_vars, non_arg_vars).
is_alias_for(local_vars, other_live_var).
is_alias_for(local_vars, nav).

is_alias_for(stack, stack).
is_alias_for(stack, stk).
is_alias_for(stack, s).
