[m-rev.] for review: functional dependencies
Mark Brown
mark at cs.mu.OZ.AU
Wed Jun 7 22:23:21 AEST 2006
Hi,
This addresses the issue that Ian raised earlier this year. Since we've
decided the change is a bugfix rather than a new feature, I'm planning
to include this on the release branch as well.
Cheers,
Mark.
Estimated hours taken: 12
Branches: main, release
Use functional dependencies on superclasses (in addition to the class itself)
to relax the restrictions on method constraints.
compiler/check_typeclass.m:
Derive induced dependencies from the class_fundep_ancestors field,
after renaming apart the ancestors and substituting parameters.
tests/hard_coded/typeclasses/Mmakefile:
tests/hard_coded/typeclasses/fundeps_6.exp:
tests/hard_coded/typeclasses/fundeps_6.m:
tests/hard_coded/typeclasses/fundeps_7.exp:
tests/hard_coded/typeclasses/fundeps_7.m:
New test cases.
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.93
diff -u -r1.93 check_typeclass.m
--- compiler/check_typeclass.m 20 Apr 2006 05:36:49 -0000 1.93
+++ compiler/check_typeclass.m 7 Jun 2006 06:45:11 -0000
@@ -1437,10 +1437,11 @@
module_info::out, bool::in, bool::out, io::di, io::uo) is det.
check_pred_type_ambiguities(PredInfo, !ModuleInfo, !FoundError, !IO) :-
+ pred_info_get_typevarset(PredInfo, TVarSet),
pred_info_get_arg_types(PredInfo, ArgTypes),
pred_info_get_class_context(PredInfo, Constraints),
prog_type.vars_list(ArgTypes, TVars),
- get_unbound_tvars(TVars, Constraints, !.ModuleInfo, UnboundTVars),
+ get_unbound_tvars(TVarSet, TVars, Constraints, !.ModuleInfo, UnboundTVars),
(
UnboundTVars = []
;
@@ -1474,7 +1475,8 @@
prog_type.vars_list(ArgTypes, ArgTVars),
list.filter((pred(V::in) is semidet :- list.member(V, ExistQVars)),
ArgTVars, ExistQArgTVars),
- get_unbound_tvars(ExistQArgTVars, constraints([], Constraints),
+ get_type_defn_tvarset(TypeDefn, TVarSet),
+ get_unbound_tvars(TVarSet, ExistQArgTVars, constraints([], Constraints),
!.ModuleInfo, UnboundTVars),
(
UnboundTVars = []
@@ -1486,12 +1488,12 @@
module_info_incr_errors(!ModuleInfo)
).
-:- pred get_unbound_tvars(list(tvar)::in, prog_constraints::in,
+:- pred get_unbound_tvars(tvarset::in, list(tvar)::in, prog_constraints::in,
module_info::in, list(tvar)::out) is det.
-get_unbound_tvars(TVars, Constraints, ModuleInfo, UnboundTVars) :-
+get_unbound_tvars(TVarSet, TVars, Constraints, ModuleInfo, UnboundTVars) :-
module_info_get_class_table(ModuleInfo, ClassTable),
- InducedFunDeps = induced_fundeps(ClassTable, Constraints),
+ InducedFunDeps = induced_fundeps(ClassTable, TVarSet, Constraints),
FunDepsClosure = fundeps_closure(InducedFunDeps, list_to_set(TVars)),
solutions.solutions(
constrained_var_not_in_closure(Constraints, FunDepsClosure),
@@ -1518,16 +1520,53 @@
range :: set(tvar)
).
-:- func induced_fundeps(class_table, prog_constraints) = induced_fundeps.
+:- func induced_fundeps(class_table, tvarset, prog_constraints)
+ = induced_fundeps.
+
+induced_fundeps(ClassTable, TVarSet, constraints(UnivCs, ExistCs))
+ = foldl(induced_fundeps_2(ClassTable, TVarSet), UnivCs,
+ foldl(induced_fundeps_2(ClassTable, TVarSet), ExistCs, [])).
+
+:- func induced_fundeps_2(class_table, tvarset, prog_constraint,
+ induced_fundeps) = induced_fundeps.
-induced_fundeps(ClassTable, constraints(UnivCs, ExistCs))
- = foldl(induced_fundeps_2(ClassTable), UnivCs,
- foldl(induced_fundeps_2(ClassTable), ExistCs, [])).
+induced_fundeps_2(ClassTable, TVarSet, Constraint, FunDeps0) = FunDeps :-
+ Constraint = constraint(Name, Args),
+ Arity = length(Args),
+ ClassDefn = map.lookup(ClassTable, class_id(Name, Arity)),
+ % The ancestors includes all superclasses of Constraint which have
+ % functional dependencies on them (possibly including Constraint itself).
+ ClassAncestors = ClassDefn ^ class_fundep_ancestors,
+ (
+ % Optimize the common case.
+ ClassAncestors = [],
+ FunDeps = FunDeps0
+ ;
+ ClassAncestors = [_ | _],
+ ClassTVarSet = ClassDefn ^ class_tvarset,
+ ClassParams = ClassDefn ^ class_vars,
+
+ % We can ignore the resulting tvarset, since any new variables
+ % will become bound when the arguments are bound. (This follows
+ % from the fact that constraints on class declarations can only use
+ % variables that appear in the head of the declaration.)
+
+ tvarset_merge_renaming(TVarSet, ClassTVarSet, _, Renaming),
+ apply_variable_renaming_to_prog_constraint_list(Renaming,
+ ClassAncestors, RenamedAncestors),
+ apply_variable_renaming_to_tvar_list(Renaming, ClassParams,
+ RenamedParams),
+ map.from_corresponding_lists(RenamedParams, Args, Subst),
+ apply_subst_to_prog_constraint_list(Subst, RenamedAncestors,
+ Ancestors),
+ FunDeps = foldl(induced_fundeps_3(ClassTable), Ancestors, FunDeps0)
+ ).
-:- func induced_fundeps_2(class_table, prog_constraint, induced_fundeps)
+:- func induced_fundeps_3(class_table, prog_constraint, induced_fundeps)
= induced_fundeps.
-induced_fundeps_2(ClassTable, constraint(Name, Args), FunDeps0) = FunDeps :-
+induced_fundeps_3(ClassTable, Constraint, FunDeps0) = FunDeps :-
+ Constraint = constraint(Name, Args),
Arity = length(Args),
ClassDefn = map.lookup(ClassTable, class_id(Name, Arity)),
FunDeps = foldl(induced_fundep(Args), ClassDefn ^ class_fundeps, FunDeps0).
Index: tests/hard_coded/typeclasses/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/typeclasses/Mmakefile,v
retrieving revision 1.56
diff -u -r1.56 Mmakefile
--- tests/hard_coded/typeclasses/Mmakefile 31 May 2006 16:00:40 -0000 1.56
+++ tests/hard_coded/typeclasses/Mmakefile 7 Jun 2006 04:20:47 -0000
@@ -25,6 +25,8 @@
fundeps_3 \
fundeps_4 \
fundeps_5 \
+ fundeps_6 \
+ fundeps_7 \
ground_constraint \
ground_constraint_2 \
ho_map \
Index: tests/hard_coded/typeclasses/fundeps_6.exp
===================================================================
RCS file: tests/hard_coded/typeclasses/fundeps_6.exp
diff -N tests/hard_coded/typeclasses/fundeps_6.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/fundeps_6.exp 7 Jun 2006 04:14:27 -0000
@@ -0,0 +1 @@
+no
Index: tests/hard_coded/typeclasses/fundeps_6.m
===================================================================
RCS file: tests/hard_coded/typeclasses/fundeps_6.m
diff -N tests/hard_coded/typeclasses/fundeps_6.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/fundeps_6.m 7 Jun 2006 04:18:22 -0000
@@ -0,0 +1,37 @@
+:- module fundeps_6.
+:- interface.
+:- import_module io.
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- typeclass a(A, X) <= (A -> X) where [
+].
+
+:- typeclass b(B, X) <= a(B, X) where [
+ % X is determined by the functional dependency on a/2, which we
+ % should inherit.
+ func b(B) = int
+].
+
+:- instance a(int, int) where [
+].
+
+:- instance b(int, int) where [
+ (b(N) = N)
+].
+
+ % X is determined by the functional dependency on a/2, which
+ % should be inherited by b/2.
+ %
+:- type foo ---> some [B, X] foo(B) => b(B, X).
+
+main(!IO) :-
+ (
+ b(1) = b(2)
+ ->
+ write_string("yes\n", !IO)
+ ;
+ write_string("no\n", !IO)
+ ).
+
Index: tests/hard_coded/typeclasses/fundeps_7.exp
===================================================================
RCS file: tests/hard_coded/typeclasses/fundeps_7.exp
diff -N tests/hard_coded/typeclasses/fundeps_7.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/fundeps_7.exp 7 Jun 2006 04:20:33 -0000
@@ -0,0 +1 @@
+no
Index: tests/hard_coded/typeclasses/fundeps_7.m
===================================================================
RCS file: tests/hard_coded/typeclasses/fundeps_7.m
diff -N tests/hard_coded/typeclasses/fundeps_7.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/typeclasses/fundeps_7.m 7 Jun 2006 04:22:10 -0000
@@ -0,0 +1,37 @@
+:- module fundeps_7.
+:- interface.
+:- import_module io.
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- typeclass a(X, A) <= (A -> X) where [
+].
+
+:- typeclass b(B, X) <= a(X, B) where [
+ % X is determined by the functional dependency on a/2, which we
+ % should inherit.
+ func b(B) = int
+].
+
+:- instance a(int, int) where [
+].
+
+:- instance b(int, int) where [
+ (b(N) = N)
+].
+
+ % X is determined by the functional dependency on a/2, which
+ % should be inherited by b/2.
+ %
+:- type foo ---> some [B, X] foo(B) => b(B, X).
+
+main(!IO) :-
+ (
+ b(1) = b(2)
+ ->
+ write_string("yes\n", !IO)
+ ;
+ write_string("no\n", !IO)
+ ).
+
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list