%-----------------------------------------------------------------------------%
% Copyright (C) 1995-1999, 2006, 2011 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%

% file: ztype.m
% main author: philip

:- module ztype.

:- interface.
:- import_module maybe, pair, word, list, assoc_list, map, zabstract.

:- type ztype
	--->	given(ident)
	;	power(ztype)
	;	cross(list(ztype))
	;	schema(slist)
	;	var(ztvar)
	;	parameter(ident)
	;	unity
	;	abbreviation(ident, list(ztype), depth, ztarity, ztype)
	.

:- type slist == assoc_list(ident, ztype).

:- type ztvar ---> ztvar(ref, int).	% ref is identifer reference
					% that introduces the variable,
					% and the int is the ordinal
					% of the generic parameter
					% represented by the variable

:- type varsource
	--->	parameter(ref, int)
	;	function_arg
	;	function_result
	;	power
	;	extension
	.

:- type apply_status ---> normal ; from_apply.

:- type varinfo ---> varinfo(expr, varsource, maybe(ztype), apply_status).

:- type subst == pair(map(ztvar, varinfo), ref).

:- func initSubst = subst.

:- func ztapply(subst, ztype) = ztype.

:- pred subst_lookup(subst::in, ztvar::in, varinfo::out) is det.
:- pred subst_lookup(ztvar::in, varinfo::out, subst::in, subst::out) is det.
:- pred subst_insert(ztvar::in, varinfo::in, subst::in, subst::out) is det.
:- pred subst_update(ztvar::in, varinfo::in, subst::in, subst::out) is det.

:- type depth == int.		% >= 1

:- type ztarity == int.		% >= 0

:- type entry ---> e(ztarity, ztype).

:- func powerEntry = entry.
:- func givenType(ident) = ztype.
:- func givenEntry(ident) = entry.
:- func branchEntry(ident, ztype) = entry.


%%%
:- import_module zabstract.

% :- type ptype == pair(int, ztype).
:- type ptypes.

:- func initPtypes = ptypes.

% :- pred addPtypes(assoc_list(ref, ptype)::in, ptypes::in, ptypes::out) is det.

:- pred add_sexpr_type(ref::in, slist::in, ptypes::in, ptypes::out) is det.

:- pred find_sexpr_type(ref::in, slist::out, ptypes::in) is det.

% :- pred findPtypes(subst::in, ref::in, list(expr)::out) is semidet.

:- type gentypes.

:- func initGenTypes = gentypes.

:- pred substToGenTypes(subst::in, gentypes::out) is det.

:- pred getGenType(gentypes::in, ref::in, maybe(list(expr))::out) is det.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- implementation.
:- import_module builtin, string, require, int.

powerEntry = e(1, power(power(var(ztvar(0, 1))))).
givenType(Id) = power(given(Id)).
givenEntry(Id) = e(0, power(given(Id))).
branchEntry(Id, T) = e(0, power(cross([T, given(Id)]))).

% This type contains information about the inferred types
% for each parameter for every reference to a generic identifier.
:- type ptypes == map(ref, slist).

initSubst = S-0 :- map__init(S).

initPtypes = PM :- map__init(PM).

add_sexpr_type(R, SL, P0, P) :- map__det_insert(R, SL, P0, P).

% *** Make this semidet, and handle failure case in zclp.m ***
find_sexpr_type(R, SL, P) :-
	map__lookup(P, R, SL).
%	Pred = (pred(SL0::out) is nondet :-
%		multi_map__nondet_search(P, R, 0-schema(SL0))),
%	solutions(Pred, Solutions),
%	( Solutions = [] ->
%		string__format("find_sexpr_type/3: ref %p not found",
%								[i(R)], Mesg),
%		error(Mesg)
%	; Solutions = [SL1] ->
%		SL = SL1
%	;	string__format("find_sexpr_type/3: ref %p multiple entries",
%								[i(R)], Mesg),
%		error(Mesg)
%	).

% findPtypes(Subst, Ref, to_exprL(L)) :-
% 	Subst = Subst1-_,
% 	map__to_assoc_list(Subst1, L0),
% 	P = (pred(_-Info::in, Ord-T::out) is semidet :-
% 		Info = varinfo(_, parameter(Ref, Ord), yes(T0), _),
% 		Ord > 0,
% 		T = ztapply(Subst, T0)),
% 		% 0 is used for the enclosing type, not just one parameter
% 	list__filter_map(P, L0, L1),
% 	% P = (pred(Ord-ztapply(Subst, T)::out) is nondet :-
% 	% 	map__member(Subst1, ztvar(Ord, _),
% 	% 		varinfo(ref(Ref, _, _)-_, _, yes(T), _)),
% 	% 	Ord > 0),
% 	%  	% 0 is used for the enclosing type, not just one parameter
% 	% solutions(P, L1),
% 	list__sort(L1, L2),
% 	assoc_list__values(L2, L).

:- type gentypes == map(ref, list(expr)).

initGenTypes = M :- map__init(M).

:- type triple ---> triple(ref, int, expr).

% Reverse ordering used because list is built up in reverse
:- pred ordSort(triple::in, triple::in, comparison_result::out) is det.
ordSort(triple(_, Ord1, _), triple(_, Ord2, _), C) :- compare(C, Ord2, Ord1).

:- pred refSort(triple::in, triple::in, comparison_result::out) is det.
refSort(triple(Ref1, _, _), triple(Ref2, _, _), C) :- compare(C, Ref1, Ref2).

substToGenTypes(Subst, GenTypes) :-
	Subst = Subst1-_,
	map__to_assoc_list(Subst1, L0),
	P = (pred(_-Info::in, triple(Ref, Ord, T)::out) is semidet :-
		Info = varinfo(_, parameter(Ref, Ord), yes(T0), _),
		T = to_expr(ztapply(Subst, T0))-0),
	list__filter_map(P, L0, L1),
	list__sort(ordSort, L1, L2),
	list__sort(refSort, L2, L3),
	listToGenTypes(L3, GenTypes).	% Group then insert in map

:- pred listToGenTypes(list(triple)::in, gentypes::out) is det.
listToGenTypes([], GenTypes) :- map__init(GenTypes).
listToGenTypes(List, GenTypes) :-
	List = [triple(Ref, _, Expr)|List1],
	map__init(M0),
	listToGenTypes(Ref, [Expr], List1, M0, GenTypes).

:- pred listToGenTypes(ref::in, list(expr)::in, list(triple)::in,
		gentypes::in, gentypes::out) is det.
listToGenTypes(Ref, ExprList, [], M0, M) :-
	map__det_insert(Ref, ExprList, M0, M).
listToGenTypes(Ref, ExprList, [triple(Ref1, _, Expr)|List], M0, M) :-
	( Ref = Ref1 ->
		listToGenTypes(Ref, [Expr|ExprList], List, M0, M)
	;	map__det_insert(Ref, ExprList, M0, M1),
		listToGenTypes(Ref1, [Expr], List, M1, M)
	).

getGenType(GenTypes, Ref, M) :-
	( map__search(GenTypes, Ref, L) ->
		M = yes(L)
	;	M = no
	).

:- func to_expr(ztype) = expr1.
to_expr(given(I)) = ref(0, I, no).
to_expr(power(T)) = powerset(to_expr(T)-0).
to_expr(cross(L)) = product(to_exprL(L)).
to_expr(schema(SL)) = sexp(sexpr(0, text(to_declL(SL), []), 0)).
to_expr(var(_)) = _ :- error("to_expr/2: converting non-ground type to expr").
to_expr(parameter(I)) = ref(0, I, no).
to_expr(unity) = _ :- error("to_expr/2: converting unity to expr").
to_expr(abbreviation(I, L, _, _, _)) = ref(0, I, yes(to_exprL(L))).

% *** Could sort this by type to produce simpler logic representation ***
:- func to_declL(slist) = list(decl).
to_declL([]) = [].
to_declL([I-T|L]) = [decl([I], to_expr(T)-0)|to_declL(L)].

:- func to_exprL(list(ztype)) = list(expr).
to_exprL([]) = [].
to_exprL([H|T]) = [to_expr(H)-0|to_exprL(T)].

ztapply(_, G) = G :- G = given(_).
ztapply(S, power(T)) = power(ztapply(S, T)).
ztapply(S, cross(L0)) = cross(L) :-
	list__map((pred(T::in, U::out) is det :-
		U = ztapply(S, T)
	), L0, L).
ztapply(S, schema(DL0)) = schema(DL) :-
	list__map(do_decl(ztapply(S)), DL0, DL).
ztapply(S, V) = T :- V = var(I),
	subst_lookup(S, I, varinfo(_, _, MT, _)),
	(MT = yes(T1), T = ztapply(S, T1) ; MT = no, T = V ).
ztapply(_, P) = P :- P = parameter(_).
ztapply(_, unity) = unity.
ztapply(S, abbreviation(I, L0, D, N, T)) = abbreviation(I, L , D, N, T) :-
	list__map((pred(IN::in, OUT::out) is det :-
		OUT = ztapply(S, IN)
	), L0, L).

:- pred do_decl(func(ztype) = ztype, pair(ident, ztype), pair(ident, ztype)).
:- mode do_decl(func(in) = out is det, in, out) is det.
do_decl(F, I-H, I-F(H)).

subst_lookup(S-_, V, VI) :-
	( map__search(S, V, VI0) ->
		VI = VI0
	;	V = ztvar(Ref, Int),
		string__format("subst_lookup/4: var %i:%i not found",
							[i(Ref), i(Int)], Str),
		error(Str)
	).

subst_lookup(V, VI, S, S) :- subst_lookup(S, V, VI).

subst_insert(V, VI, S0-G, S-G) :-
	( map__insert(V, VI, S0, S1) ->
		S = S1
	;	V = ztvar(Ref, Int),
		string__format("subst_insert/4: var %i:%i already in subst",
							[i(Ref), i(Int)], Str),
		error(Str)
	).

subst_update(V, VI, S0-G, S-G) :-
	( map__update(V, VI, S0, S1) ->
		S = S1
	;	V = ztvar(Ref, Int),
		string__format("subst_update/4: var %i:%i not found",
							[i(Ref), i(Int)], Str),
		error(Str)
	).
