mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-26 23:04:15 +00:00
306 lines
8.7 KiB
Mathematica
306 lines
8.7 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% 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 assoc_list.
|
|
:- import_module list.
|
|
:- import_module map.
|
|
:- import_module maybe.
|
|
:- import_module pair.
|
|
:- import_module word.
|
|
:- import_module 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.
|
|
|
|
%%%
|
|
|
|
% :- 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 require.
|
|
:- import_module string.
|
|
|
|
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),
|
|
% ( if Solutions = [] then
|
|
% string.format("find_sexpr_type/3: ref %p not found",
|
|
% [i(R)], Mesg),
|
|
% error(Mesg)
|
|
% else if Solutions = [SL1] then
|
|
% SL = SL1
|
|
% else
|
|
% 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) :-
|
|
( if Ref = Ref1 then
|
|
listToGenTypes(Ref, [Expr | ExprList], List, M0, M)
|
|
else
|
|
map.det_insert(Ref, ExprList, M0, M1),
|
|
listToGenTypes(Ref1, [Expr], List, M1, M)
|
|
).
|
|
|
|
getGenType(GenTypes, Ref, M) :-
|
|
( if map.search(GenTypes, Ref, L) then
|
|
M = yes(L)
|
|
else
|
|
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) :-
|
|
( if map.search(S, V, VI0) then
|
|
VI = VI0
|
|
else
|
|
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) :-
|
|
( if map.insert(V, VI, S0, S1) then
|
|
S = S1
|
|
else
|
|
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) :-
|
|
( if map.update(V, VI, S0, S1) then
|
|
S = S1
|
|
else
|
|
V = ztvar(Ref, Int),
|
|
string.format("subst_update/4: var %i:%i not found",
|
|
[i(Ref), i(Int)], Str),
|
|
error(Str)
|
|
).
|