mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-18 07:15:19 +00:00
3fc6b3f128
Estimated hours taken: 30 Branches: main Change the representation of types in the compiler. We also add some support for handling kinds, which will be used later when we have a kind system. There are a number of places where kinds are not yet handled correctly -- we assume that all kinds will be `star'. Each of these locations is flagged with a comment that contains "XXX kind inference:". compiler/prog_data.m: Implement the new version of type (type). Change the definition of type_param to be a variable instead of a term, since all parameters must be variables anyway. Implement versions of varset.merge_* which work with tvarsets and produce renamings instead of substitutions. Renamings are more convenient than substitutions because we don't need to know the kinds of type variables in order to build the renaming, and in any case the substitutions shouldn't have anything other than variables in the range so renamings will be more efficient and safe. Define the type of kinds, and provide a couple of utility predicates to operate on them. compiler/prog_io.m: Parse type definition heads as a sym_name and list of type_params, rather than a functor. Handle this change in other predicates. Allow parse errors to be returned by get_with_type/3, and handle these errors. Remove parse_type/2. This predicate didn't do any processing, it just forwarded handling to convert_type/2. compiler/prog_io_typeclass.m: Change type_is_functor_and_vars to handle the new representation of types. In doing so, we retain the old behaviour that pure predicates pass this test, but no other pred or func types. This behaviour is arguably incorrect, but there is little point changing the behaviour at the moment. Instead we should remove these kind of restrictions entirely, but that should be done later. compiler/prog_io_util.m: Provide predicates to both parse and unparse types. We need to unparse types before printing them out, since we do a lot of special case handling when printing out terms and we don't want to duplicate this functionality for types. compiler/module_qual.m: Remove report_invalid_type. We now report ill-formed types during parsing. compiler/superhomogeneous.m: Handle errors from the parsing of type expressions. compiler/prog_out.m: Provide a predicate to convert builtin_types to their string names, and vice-versa. compiler/prog_type.m: Add a bunch of simple tests to use on types which may have kind annotations present. In such cases, types do not have a canonical representation so the simple handling of these tests is not what we want. (Note that these are only required in early phases. The kind annotations -- when they are implemented -- will be removed before type checking.) Consistently handle the application of renamings, substitutions and recursive substitutions to various data structures. compiler/mercury_to_mercury.m: Implement mercury_output_type, mercury_format_type and mercury_type_to_string. These convert the type to a term before formatting -- the reason for this is so that appropriate parentheses are used when formatting operators. This results in some slight changes to error messages, which are reflected in changes to the expected output files in the tests. Remove the old version of mercury_type_to_string. Change the argument ordering of mercury_format_var to be consistent with mercury_format_type. (Other predicates in this module should probably be changed in a similar way, since this argument ordering is more amenable to higher-order programming. But that can be left for another change.) compiler/type_util.m: Implement type unification. The behaviour is much the same as the previous behaviour, except that we now handle apply/N types properly, and we also allow for kind annotations. Implement an occurs check for types. Remove the example definition of replace_eqv_type. It isn't used and would no longer work anyway even if it would have worked before. Add a tvar_kind_map field to ctor_defn. The functions type_info_type and type_ctor_info_type now return types with `void' as their argument, rather than the type that the type_info or type_ctor_info was for. Remove type_util.real_vars/2, since it no longer does anything different from prog_type.vars/2. Remove the commented out implementation of type_to_ctor_and_args/3. Its implementation is in prog_type.m, and has changed significantly in any case. compiler/add_clause.m: Move parse_purity_annotation/3 to prog_io_util.m. compiler/check_typeclass.m: Remove apply_substitution_to_var_list/3, since we now have predicates in prog_type.m to handle such things. compiler/continuation_info.m: compiler/trace.m: Use prog_type.vars/2 instead of type_util.real_vars/2. The two predicates have the same meaning now since type_infos don't contain any type variables. compiler/hlds_data.m: Add tvar_kind_map fields to hlds_type_defn and hlds_class_defn. compiler/hlds_pred.m: Add a tvar_kind_map field to pred_info. compiler/polymorphism.m: Add a tvar_kind_map field to poly_info. Remove unify_corresponding_types, which is no longer used. compiler/hlds_out.m: Use mercury_output_type/5 instead of term_io__write_term/4 and mercury_output_term/5. compiler/post_typecheck.m: Build the void substitution directly rather than building intermediate lists. compiler/recompilation.version.m: Use term__list_subsumes instead of type_list_subsumes, which now operates only on types. This follows up on what was suggested in an XXX comment. compiler/typecheck_errors.m: Use unparse_type/2 to format error messages. compiler/typecheck_info.m: Don't export write_type_with_bindings/5. It is no longer used outside of this module. compiler/*.m: Conform to the above changes. library/rtti_implementation.m: Fix a syntax error that went undetected in our previous implementation, and amazingly enough was compiled correctly anyway. library/term.m: Move the versions of term__unify, term__unify_list and term__list_subsumes that were implemented specifically for types to here. The version of term_unify that takes a list of bound variables (i.e., variables that should not be bound any further) is used by the subsumption check, which in turn is used by recompilation.version.m. tests/invalid/kind.err_exp: tests/invalid/tc_err1.err_exp: tests/invalid/tc_err2.err_exp: tests/misc_tests/pretty_print_test.exp: Update the expected output of these tests to match what we now do.
938 lines
36 KiB
Mathematica
938 lines
36 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 2005 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: typeclasses.m
|
|
% Main author: mark (including code by fjh and dgj)
|
|
%
|
|
% The module implements context reduction, which is the part of type checking
|
|
% which implements the type class system.
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module check_hlds.typeclasses.
|
|
|
|
:- interface.
|
|
|
|
:- import_module check_hlds.typecheck_info.
|
|
:- import_module hlds.hlds_data.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module parse_tree.prog_data.
|
|
|
|
:- import_module io.
|
|
|
|
% perform_context_reduction(OrigTypeAssignSet, Info0, Info) is true
|
|
% iff either
|
|
% (a) Info is the typecheck_info that results from performing
|
|
% context reduction on the type_assigns in Info0, or
|
|
% (b) if there is no valid context reduction, then Info is Info0
|
|
% with the type assign set replaced by OrigTypeAssignSet (see below).
|
|
%
|
|
% Context reduction is the process of eliminating redundant constraints
|
|
% from the constraints in the type_assign and adding the proof of the
|
|
% constraint's redundancy to the proofs in the same type_assign. There
|
|
% are three ways in which a constraint may be redundant:
|
|
%
|
|
% - if a constraint occurs in the pred/func declaration for this
|
|
% predicate or function, then it is redundant
|
|
% (in this case, the proof is trivial, so there is no need
|
|
% to record it in the proof map)
|
|
% - if a constraint is present in the set of constraints and all
|
|
% of the "superclass" constraints for the constraints are all
|
|
% present, then all the superclass constraints are eliminated
|
|
% - if there is an instance declaration that may be applied, the
|
|
% constraint is replaced by the constraints from that instance
|
|
% declaration
|
|
%
|
|
% In addition, context reduction removes repeated constraints.
|
|
%
|
|
% During context reduction we also try to "improve" the type binding
|
|
% in the given type_assign (that is, binding the type variables in
|
|
% such a way that the satisfiability of the constraints is not
|
|
% changed). This is done by applying improvement rules inside the
|
|
% fixpoint loop. The improvement rules are those which are induced
|
|
% by functional dependencies attached to typeclass declarations.
|
|
%
|
|
% If context reduction fails on a type_assign, that type_assign is
|
|
% removed from the type_assign_set. Context reduction fails if there is
|
|
% a constraint where the type of (at least) one of the arguments to
|
|
% the constraint has its top level functor bound, but there is no
|
|
% instance declaration for that type.
|
|
%
|
|
% If all type_assigns from the typecheck_info are rejected, than an
|
|
% appropriate error message is given, the type_assign_set is
|
|
% restored to the original one given by OrigTypeAssignSet,
|
|
% but without any typeclass constraints.
|
|
% The reason for this is to avoid reporting the same error at
|
|
% subsequent calls to perform_context_reduction.
|
|
%
|
|
:- pred perform_context_reduction(type_assign_set::in,
|
|
typecheck_info::in, typecheck_info::out, io::di, io::uo) is det.
|
|
|
|
% Apply context reduction to the list of class constraints by applying
|
|
% the instance rules or superclass rules, building up proofs for
|
|
% redundant constraints.
|
|
%
|
|
:- pred typeclasses__reduce_context_by_rule_application(class_table::in,
|
|
instance_table::in, superclass_table::in, head_type_params::in,
|
|
tsubst::in, tsubst::out, tvarset::in, tvarset::out,
|
|
constraint_proof_map::in, constraint_proof_map::out,
|
|
constraint_map::in, constraint_map::out,
|
|
hlds_constraints::in, hlds_constraints::out) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module check_hlds.type_util.
|
|
:- import_module check_hlds.typecheck_errors.
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module parse_tree.prog_type.
|
|
|
|
:- import_module bool.
|
|
:- import_module int.
|
|
:- import_module list.
|
|
:- import_module map.
|
|
:- import_module multi_map.
|
|
:- import_module set.
|
|
:- import_module std_util.
|
|
:- import_module term.
|
|
:- import_module varset.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
perform_context_reduction(OrigTypeAssignSet, !Info, !IO) :-
|
|
checkpoint("before context reduction", !Info, !IO),
|
|
typecheck_info_get_module_info(!.Info, ModuleInfo),
|
|
module_info_classes(ModuleInfo, ClassTable),
|
|
module_info_superclasses(ModuleInfo, SuperClassTable),
|
|
module_info_instances(ModuleInfo, InstanceTable),
|
|
typecheck_info_get_type_assign_set(!.Info, TypeAssignSet0),
|
|
list__filter_map(
|
|
reduce_type_assign_context(ClassTable, SuperClassTable,
|
|
InstanceTable),
|
|
TypeAssignSet0, TypeAssignSet),
|
|
(
|
|
% Check that this context reduction hasn't eliminated
|
|
% all the type assignments.
|
|
TypeAssignSet = [],
|
|
TypeAssignSet0 \= []
|
|
->
|
|
report_unsatisfiable_constraints(TypeAssignSet0, !Info, !IO),
|
|
DeleteConstraints = (pred(TA0::in, TA::out) is det :-
|
|
type_assign_get_typeclass_constraints(TA0,
|
|
Constraints0),
|
|
Constraints = (Constraints0
|
|
^ unproven := [])
|
|
^ redundant := multi_map.init,
|
|
type_assign_set_typeclass_constraints(Constraints,
|
|
TA0, TA)
|
|
),
|
|
list__map(DeleteConstraints, OrigTypeAssignSet,
|
|
NewTypeAssignSet),
|
|
typecheck_info_set_type_assign_set(NewTypeAssignSet, !Info)
|
|
;
|
|
typecheck_info_set_type_assign_set(TypeAssignSet, !Info)
|
|
).
|
|
|
|
:- pred reduce_type_assign_context(class_table::in, superclass_table::in,
|
|
instance_table::in, type_assign::in, type_assign::out) is semidet.
|
|
|
|
reduce_type_assign_context(ClassTable, SuperClassTable, InstanceTable,
|
|
!TypeAssign) :-
|
|
type_assign_get_head_type_params(!.TypeAssign, HeadTypeParams),
|
|
type_assign_get_type_bindings(!.TypeAssign, Bindings0),
|
|
type_assign_get_typeclass_constraints(!.TypeAssign, Constraints0),
|
|
type_assign_get_typevarset(!.TypeAssign, TVarSet0),
|
|
type_assign_get_constraint_proofs(!.TypeAssign, Proofs0),
|
|
type_assign_get_constraint_map(!.TypeAssign, ConstraintMap0),
|
|
|
|
typeclasses__reduce_context_by_rule_application(ClassTable,
|
|
InstanceTable, SuperClassTable, HeadTypeParams,
|
|
Bindings0, Bindings, TVarSet0, TVarSet, Proofs0, Proofs,
|
|
ConstraintMap0, ConstraintMap, Constraints0, Constraints),
|
|
check_satisfiability(Constraints ^ unproven, HeadTypeParams),
|
|
|
|
type_assign_set_type_bindings(Bindings, !TypeAssign),
|
|
type_assign_set_typeclass_constraints(Constraints, !TypeAssign),
|
|
type_assign_set_typevarset(TVarSet, !TypeAssign),
|
|
type_assign_set_constraint_proofs(Proofs, !TypeAssign),
|
|
type_assign_set_constraint_map(ConstraintMap, !TypeAssign).
|
|
|
|
typeclasses__reduce_context_by_rule_application(ClassTable, InstanceTable,
|
|
SuperClassTable, HeadTypeParams, !Bindings, !TVarSet, !Proofs,
|
|
!ConstraintMap, !Constraints) :-
|
|
typeclasses__reduce_context_by_rule_application_2(ClassTable,
|
|
InstanceTable, SuperClassTable, HeadTypeParams, !Bindings,
|
|
!TVarSet, !Proofs, !ConstraintMap, !Constraints,
|
|
!.Constraints ^ unproven, _).
|
|
|
|
:- pred typeclasses__reduce_context_by_rule_application_2(class_table::in,
|
|
instance_table::in, superclass_table::in, head_type_params::in,
|
|
tsubst::in, tsubst::out, tvarset::in, tvarset::out,
|
|
constraint_proof_map::in, constraint_proof_map::out,
|
|
constraint_map::in, constraint_map::out,
|
|
hlds_constraints::in, hlds_constraints::out,
|
|
list(hlds_constraint)::in, list(hlds_constraint)::out) is det.
|
|
|
|
typeclasses__reduce_context_by_rule_application_2(ClassTable, InstanceTable,
|
|
SuperClassTable, HeadTypeParams, !Bindings, !TVarSet, !Proofs,
|
|
!ConstraintMap, !Constraints, !Seen) :-
|
|
apply_rec_subst_to_constraints(!.Bindings, !Constraints),
|
|
apply_improvement_rules(ClassTable, InstanceTable, HeadTypeParams,
|
|
!.Constraints, !TVarSet, !Bindings, AppliedImprovementRule),
|
|
|
|
% We want to make sure that any changes to the bindings are
|
|
% reflected in the constraints, so that the full effect of the
|
|
% improvement rules applies as soon as possible. We therefore
|
|
% apply the bindings to the constraints (but only if the
|
|
% bindings have actually changed since they were last applied).
|
|
%
|
|
(
|
|
AppliedImprovementRule = yes,
|
|
apply_rec_subst_to_constraints(!.Bindings, !Constraints)
|
|
;
|
|
AppliedImprovementRule = no
|
|
),
|
|
|
|
eliminate_assumed_constraints(!ConstraintMap, !Constraints,
|
|
EliminatedAssumed),
|
|
apply_instance_rules(ClassTable, InstanceTable, !TVarSet, !Proofs,
|
|
!ConstraintMap, !Seen, !Constraints, AppliedInstanceRule),
|
|
% XXX kind inference:
|
|
% We assume that all tvars have kind `star'.
|
|
map__init(KindMap),
|
|
apply_class_rules(SuperClassTable, !.TVarSet, KindMap, !Proofs,
|
|
!ConstraintMap, !Constraints, AppliedClassRule),
|
|
(
|
|
AppliedImprovementRule = no,
|
|
EliminatedAssumed = no,
|
|
AppliedInstanceRule = no,
|
|
AppliedClassRule = no
|
|
->
|
|
% We have reached fixpoint.
|
|
%
|
|
sort_and_merge_dups(!Constraints)
|
|
;
|
|
typeclasses__reduce_context_by_rule_application_2(ClassTable,
|
|
InstanceTable, SuperClassTable, HeadTypeParams,
|
|
!Bindings, !TVarSet, !Proofs, !ConstraintMap,
|
|
!Constraints, !Seen)
|
|
).
|
|
|
|
:- pred sort_and_merge_dups(hlds_constraints::in, hlds_constraints::out)
|
|
is det.
|
|
|
|
sort_and_merge_dups(!Constraints) :-
|
|
% Should we also sort and merge the other fields?
|
|
Unproven0 = !.Constraints ^ unproven,
|
|
list__sort(compare_hlds_constraints, Unproven0, Unproven1),
|
|
merge_adjacent_constraints(Unproven1, Unproven),
|
|
!:Constraints = !.Constraints ^ unproven := Unproven.
|
|
|
|
:- pred merge_adjacent_constraints(list(hlds_constraint)::in,
|
|
list(hlds_constraint)::out) is det.
|
|
|
|
merge_adjacent_constraints([], []).
|
|
merge_adjacent_constraints([C | Cs], Constraints) :-
|
|
merge_adjacent_constraints_2(C, Cs, Constraints).
|
|
|
|
:- pred merge_adjacent_constraints_2(hlds_constraint::in,
|
|
list(hlds_constraint)::in, list(hlds_constraint)::out) is det.
|
|
|
|
merge_adjacent_constraints_2(C0, [], [C0]).
|
|
merge_adjacent_constraints_2(C0, [C1 | Cs], Constraints) :-
|
|
(
|
|
merge_constraints(C0, C1, C)
|
|
->
|
|
merge_adjacent_constraints_2(C, Cs, Constraints)
|
|
;
|
|
merge_adjacent_constraints_2(C1, Cs, Constraints0),
|
|
Constraints = [C0 | Constraints0]
|
|
).
|
|
|
|
% merge_constraints(A, B, C) succeeds if A and B represent equivalent
|
|
% constraints. In this case, C is the equivalent constraint with the
|
|
% list of ids being the union of the ids of A and B.
|
|
%
|
|
:- pred merge_constraints(hlds_constraint::in, hlds_constraint::in,
|
|
hlds_constraint::out) is semidet.
|
|
|
|
merge_constraints(constraint(IdsA, Name, Types), constraint(IdsB, Name, Types),
|
|
constraint(Ids, Name, Types)) :-
|
|
list__append(IdsA, IdsB, Ids0),
|
|
list__sort_and_remove_dups(Ids0, Ids).
|
|
|
|
:- pred apply_improvement_rules(class_table::in, instance_table::in,
|
|
head_type_params::in, hlds_constraints::in, tvarset::in, tvarset::out,
|
|
tsubst::in, tsubst::out, bool::out) is det.
|
|
|
|
apply_improvement_rules(ClassTable, InstanceTable, HeadTypeParams, Constraints,
|
|
!TVarSet, !Bindings, Changed) :-
|
|
% XXX should we sort and merge the constraints here?
|
|
do_class_improvement(ClassTable, HeadTypeParams, Constraints,
|
|
!Bindings, Changed1),
|
|
% XXX do we really need to modify the varset? See the comment above
|
|
% find_matching_instance_rule.
|
|
do_instance_improvement(ClassTable, InstanceTable, HeadTypeParams,
|
|
Constraints, !TVarSet, !Bindings, Changed2),
|
|
Changed = bool__or(Changed1, Changed2).
|
|
|
|
:- pred do_class_improvement(class_table::in, head_type_params::in,
|
|
hlds_constraints::in, tsubst::in, tsubst::out, bool::out) is det.
|
|
|
|
do_class_improvement(ClassTable, HeadTypeParams, Constraints, !Bindings,
|
|
Changed) :-
|
|
Redundant = Constraints ^ redundant,
|
|
Assumed = Constraints ^ assumed,
|
|
multi_map__keys(Redundant, ClassIds),
|
|
list__foldl2(
|
|
do_class_improvement_2(ClassTable, HeadTypeParams, Redundant,
|
|
Assumed),
|
|
ClassIds, !Bindings, no, Changed).
|
|
|
|
:- pred do_class_improvement_2(class_table::in, head_type_params::in,
|
|
redundant_constraints::in, list(hlds_constraint)::in, class_id::in,
|
|
tsubst::in, tsubst::out, bool::in, bool::out) is det.
|
|
|
|
do_class_improvement_2(ClassTable, HeadTypeParams, RedundantConstraints,
|
|
Assumed, ClassId, !Bindings, !Changed) :-
|
|
map__lookup(ClassTable, ClassId, ClassDefn),
|
|
FunDeps = ClassDefn ^ class_fundeps,
|
|
map__lookup(RedundantConstraints, ClassId, Constraints),
|
|
do_class_improvement_by_pairs(Constraints, FunDeps, HeadTypeParams,
|
|
!Bindings, !Changed),
|
|
list__filter(has_class_id(ClassId), Assumed, ThisClassAssumed),
|
|
do_class_improvement_by_assumed(ThisClassAssumed, Constraints, FunDeps,
|
|
HeadTypeParams, !Bindings, !Changed).
|
|
|
|
:- pred has_class_id(class_id::in, hlds_constraint::in) is semidet.
|
|
|
|
has_class_id(class_id(Name, Arity), constraint(_, Name, Args)) :-
|
|
list__length(Args, Arity).
|
|
|
|
% Try to find an opportunity for improvement for each (unordered)
|
|
% pair of constraints from the list.
|
|
%
|
|
:- pred do_class_improvement_by_pairs(list(hlds_constraint)::in,
|
|
hlds_class_fundeps::in, head_type_params::in, tsubst::in, tsubst::out,
|
|
bool::in, bool::out) is det.
|
|
|
|
do_class_improvement_by_pairs([], _, _, !Bindings, !Changed).
|
|
do_class_improvement_by_pairs([Constraint | Constraints], FunDeps,
|
|
HeadTypeParams, !Bindings, !Changed) :-
|
|
do_class_improvement_by_pairs_2(Constraint, Constraints, FunDeps,
|
|
HeadTypeParams, !Bindings, !Changed),
|
|
do_class_improvement_by_pairs(Constraints, FunDeps, HeadTypeParams,
|
|
!Bindings, !Changed).
|
|
|
|
:- pred do_class_improvement_by_pairs_2(hlds_constraint::in,
|
|
list(hlds_constraint)::in, hlds_class_fundeps::in,
|
|
head_type_params::in, tsubst::in, tsubst::out, bool::in, bool::out)
|
|
is det.
|
|
|
|
do_class_improvement_by_pairs_2(_, [], _, _, !Bindings, !Changed).
|
|
do_class_improvement_by_pairs_2(Constraint, [HeadConstraint | TailConstraints],
|
|
FunDeps, HeadTypeParams, !Bindings, !Changed) :-
|
|
do_class_improvement_pair(Constraint, HeadConstraint, FunDeps,
|
|
HeadTypeParams, !Bindings, !Changed),
|
|
do_class_improvement_by_pairs_2(Constraint, TailConstraints, FunDeps,
|
|
HeadTypeParams, !Bindings, !Changed).
|
|
|
|
% Try to find an opportunity for improvement for each pair of
|
|
% constraints where one comes from the assumed constraints and the
|
|
% other comes from the redundant constraints.
|
|
%
|
|
:- pred do_class_improvement_by_assumed(list(hlds_constraint)::in,
|
|
list(hlds_constraint)::in, hlds_class_fundeps::in,
|
|
head_type_params::in, tsubst::in, tsubst::out, bool::in, bool::out)
|
|
is det.
|
|
|
|
do_class_improvement_by_assumed(Assumed, Constraints, FunDeps, HeadTypeParams,
|
|
!Bindings, !Changed) :-
|
|
list__foldl2(
|
|
do_class_improvement_by_assumed_2(Constraints, FunDeps,
|
|
HeadTypeParams),
|
|
Assumed, !Bindings, !Changed).
|
|
|
|
:- pred do_class_improvement_by_assumed_2(list(hlds_constraint)::in,
|
|
hlds_class_fundeps::in, head_type_params::in, hlds_constraint::in,
|
|
tsubst::in, tsubst::out, bool::in, bool::out) is det.
|
|
|
|
do_class_improvement_by_assumed_2([], _, _, _, !Bindings, !Changed).
|
|
do_class_improvement_by_assumed_2([Constraint | Constraints], FunDeps,
|
|
HeadTypeParams, Assumed, !Bindings, !Changed) :-
|
|
do_class_improvement_pair(Constraint, Assumed, FunDeps, HeadTypeParams,
|
|
!Bindings, !Changed),
|
|
do_class_improvement_by_assumed_2(Constraints, FunDeps, HeadTypeParams,
|
|
Assumed, !Bindings, !Changed).
|
|
|
|
% Try to find an opportunity for improvement for this pair of
|
|
% constraints, using each fundep in turn.
|
|
%
|
|
:- pred do_class_improvement_pair(hlds_constraint::in, hlds_constraint::in,
|
|
hlds_class_fundeps::in, head_type_params::in, tsubst::in, tsubst::out,
|
|
bool::in, bool::out) is det.
|
|
|
|
do_class_improvement_pair(_, _, [], _, !Bindings, !Changed).
|
|
do_class_improvement_pair(ConstraintA, ConstraintB, [FunDep | FunDeps],
|
|
HeadTypeParams, !Bindings, !Changed) :-
|
|
do_class_improvement_fundep(ConstraintA, ConstraintB, FunDep,
|
|
HeadTypeParams, !Bindings, !Changed),
|
|
do_class_improvement_pair(ConstraintA, ConstraintB, FunDeps,
|
|
HeadTypeParams, !Bindings, !Changed).
|
|
|
|
:- pred do_class_improvement_fundep(hlds_constraint::in, hlds_constraint::in,
|
|
hlds_class_fundep::in, head_type_params::in, tsubst::in, tsubst::out,
|
|
bool::in, bool::out) is det.
|
|
|
|
do_class_improvement_fundep(ConstraintA, ConstraintB, FunDep, HeadTypeParams,
|
|
!Bindings, !Changed) :-
|
|
ConstraintA = constraint(_, _, TypesA),
|
|
ConstraintB = constraint(_, _, TypesB),
|
|
FunDep = fundep(Domain, Range),
|
|
(
|
|
%
|
|
% We already know that the name/arity of the
|
|
% constraints match, since we have partitioned them
|
|
% already.
|
|
%
|
|
lists_match_on_elements(Domain, TypesA, TypesB),
|
|
\+ lists_match_on_elements(Range, TypesA, TypesB),
|
|
|
|
%
|
|
% The unification can fail if type parameters in the
|
|
% declaration would be bound by the improvement rule.
|
|
% This means that the declaration is not as specific
|
|
% as it could be, but that is not a problem for us.
|
|
%
|
|
unify_on_elements(Range, TypesA, TypesB, HeadTypeParams,
|
|
!Bindings)
|
|
->
|
|
!:Changed = yes
|
|
;
|
|
true
|
|
).
|
|
|
|
:- pred do_instance_improvement(class_table::in, instance_table::in,
|
|
head_type_params::in, hlds_constraints::in, tvarset::in, tvarset::out,
|
|
tsubst::in, tsubst::out, bool::out) is det.
|
|
|
|
do_instance_improvement(ClassTable, InstanceTable, HeadTypeParams, Constraints,
|
|
!TVarSet, !Bindings, Changed) :-
|
|
RedundantConstraints = Constraints ^ redundant,
|
|
map__keys(RedundantConstraints, ClassIds),
|
|
list__foldl3(
|
|
do_instance_improvement_2(ClassTable, InstanceTable,
|
|
HeadTypeParams, RedundantConstraints),
|
|
ClassIds, !TVarSet, !Bindings, no, Changed).
|
|
|
|
:- pred do_instance_improvement_2(class_table::in, instance_table::in,
|
|
head_type_params::in, redundant_constraints::in, class_id::in,
|
|
tvarset::in, tvarset::out, tsubst::in, tsubst::out,
|
|
bool::in, bool::out) is det.
|
|
|
|
do_instance_improvement_2(ClassTable, InstanceTable, HeadTypeParams,
|
|
RedundantConstraints, ClassId, !TVarSet, !Bindings,
|
|
!Changed) :-
|
|
map__lookup(ClassTable, ClassId, ClassDefn),
|
|
FunDeps = ClassDefn ^ class_fundeps,
|
|
map__lookup(InstanceTable, ClassId, InstanceDefns),
|
|
map__lookup(RedundantConstraints, ClassId, Constraints),
|
|
list__foldl3(
|
|
do_instance_improvement_3(Constraints, FunDeps,
|
|
HeadTypeParams),
|
|
InstanceDefns, !TVarSet, !Bindings, !Changed).
|
|
|
|
:- pred do_instance_improvement_3(list(hlds_constraint)::in,
|
|
hlds_class_fundeps::in, head_type_params::in, hlds_instance_defn::in,
|
|
tvarset::in, tvarset::out, tsubst::in, tsubst::out,
|
|
bool::in, bool::out) is det.
|
|
|
|
do_instance_improvement_3(Constraints, FunDeps, HeadTypeParams, InstanceDefn,
|
|
!TVarSet, !Bindings, !Changed) :-
|
|
InstanceTVarSet = InstanceDefn ^ instance_tvarset,
|
|
InstanceTypes0 = InstanceDefn ^ instance_types,
|
|
tvarset_merge_renaming(!.TVarSet, InstanceTVarSet, NewTVarSet,
|
|
Renaming),
|
|
apply_variable_renaming_to_type_list(Renaming, InstanceTypes0,
|
|
InstanceTypes),
|
|
list__foldl2(
|
|
do_instance_improvement_4(FunDeps, InstanceTypes,
|
|
HeadTypeParams),
|
|
Constraints, !Bindings, no, Changed0),
|
|
(
|
|
Changed0 = yes,
|
|
!:TVarSet = NewTVarSet,
|
|
!:Changed = yes
|
|
;
|
|
Changed0 = no
|
|
).
|
|
|
|
:- pred do_instance_improvement_4(hlds_class_fundeps::in, list(type)::in,
|
|
head_type_params::in, hlds_constraint::in, tsubst::in, tsubst::out,
|
|
bool::in, bool::out) is det.
|
|
|
|
do_instance_improvement_4(FunDeps, InstanceTypes, HeadTypeParams, Constraint,
|
|
!Bindings, !Changed) :-
|
|
list__foldl2(
|
|
do_instance_improvement_fundep(Constraint, InstanceTypes,
|
|
HeadTypeParams),
|
|
FunDeps, !Bindings, !Changed).
|
|
|
|
:- pred do_instance_improvement_fundep(hlds_constraint::in, list(type)::in,
|
|
head_type_params::in, hlds_class_fundep::in, tsubst::in, tsubst::out,
|
|
bool::in, bool::out) is det.
|
|
|
|
do_instance_improvement_fundep(Constraint, InstanceTypes0, HeadTypeParams,
|
|
FunDep, !Bindings, !Changed) :-
|
|
Constraint = constraint(_, _, ConstraintTypes),
|
|
FunDep = fundep(Domain, Range),
|
|
(
|
|
%
|
|
% We already know that the name/arity of the
|
|
% constraints match, since we have partitioned them
|
|
% already.
|
|
%
|
|
subsumes_on_elements(Domain, InstanceTypes0, ConstraintTypes,
|
|
Subst),
|
|
apply_rec_subst_to_type_list(Subst, InstanceTypes0,
|
|
InstanceTypes),
|
|
\+ lists_match_on_elements(Range, InstanceTypes,
|
|
ConstraintTypes),
|
|
|
|
%
|
|
% The unification can fail if type parameters in the
|
|
% declaration would be bound by the improvement rule.
|
|
% This means that the declaration is not as specific
|
|
% as it could be, but that is not a problem for us.
|
|
%
|
|
unify_on_elements(Range, InstanceTypes, ConstraintTypes,
|
|
HeadTypeParams, !Bindings)
|
|
->
|
|
!:Changed = yes
|
|
;
|
|
true
|
|
).
|
|
|
|
% For each index in the set, check that the types in the corresponding
|
|
% positions in the lists are identical.
|
|
%
|
|
:- pred lists_match_on_elements(set(hlds_class_argpos)::in, list(type)::in,
|
|
list(type)::in) is semidet.
|
|
|
|
lists_match_on_elements(Elements, TypesA, TypesB) :-
|
|
RTypesA = restrict_list_elements(Elements, TypesA),
|
|
RTypesB = restrict_list_elements(Elements, TypesB),
|
|
RTypesA = RTypesB.
|
|
|
|
% For each index in the set, unify the types in the corresponding
|
|
% positions in the lists and add to the current bindings.
|
|
%
|
|
:- pred unify_on_elements(set(hlds_class_argpos)::in, list(type)::in,
|
|
list(type)::in, head_type_params::in, tsubst::in, tsubst::out)
|
|
is semidet.
|
|
|
|
unify_on_elements(Elements, TypesA, TypesB, HeadTypeParams, !Bindings) :-
|
|
RTypesA = restrict_list_elements(Elements, TypesA),
|
|
RTypesB = restrict_list_elements(Elements, TypesB),
|
|
type_unify_list(RTypesA, RTypesB, HeadTypeParams, !Bindings).
|
|
|
|
% Analogous to type_list_subsumes except that it only checks those
|
|
% elements of the list specified by the set of indices.
|
|
%
|
|
:- pred subsumes_on_elements(set(hlds_class_argpos)::in, list(type)::in,
|
|
list(type)::in, tsubst::out) is semidet.
|
|
|
|
subsumes_on_elements(Elements, TypesA, TypesB, Subst) :-
|
|
RTypesA = restrict_list_elements(Elements, TypesA),
|
|
RTypesB = restrict_list_elements(Elements, TypesB),
|
|
prog_type__vars_list(RTypesB, RTypesBVars),
|
|
map__init(Subst0),
|
|
type_unify_list(RTypesA, RTypesB, RTypesBVars, Subst0, Subst).
|
|
|
|
:- pred eliminate_assumed_constraints(constraint_map::in, constraint_map::out,
|
|
hlds_constraints::in, hlds_constraints::out, bool::out) is det.
|
|
|
|
eliminate_assumed_constraints(!ConstraintMap, !Constraints, Changed) :-
|
|
!.Constraints = constraints(Unproven0, Assumed, Redundant),
|
|
eliminate_assumed_constraints_2(Assumed, !ConstraintMap,
|
|
Unproven0, Unproven, Changed),
|
|
!:Constraints = constraints(Unproven, Assumed, Redundant).
|
|
|
|
:- pred eliminate_assumed_constraints_2(list(hlds_constraint)::in,
|
|
constraint_map::in, constraint_map::out,
|
|
list(hlds_constraint)::in, list(hlds_constraint)::out,
|
|
bool::out) is det.
|
|
|
|
eliminate_assumed_constraints_2(_, !ConstraintMap, [], [], no).
|
|
eliminate_assumed_constraints_2(AssumedCs, !ConstraintMap, [C | Cs], NewCs,
|
|
Changed) :-
|
|
eliminate_assumed_constraints_2(AssumedCs, !ConstraintMap, Cs, NewCs0,
|
|
Changed0),
|
|
(
|
|
some [A] (
|
|
list__member(A, AssumedCs),
|
|
matching_constraints(A, C)
|
|
)
|
|
->
|
|
update_constraint_map(C, !ConstraintMap),
|
|
NewCs = NewCs0,
|
|
Changed = yes
|
|
;
|
|
NewCs = [C | NewCs0],
|
|
Changed = Changed0
|
|
).
|
|
|
|
:- pred apply_instance_rules(class_table::in, instance_table::in,
|
|
tvarset::in, tvarset::out,
|
|
constraint_proof_map::in, constraint_proof_map::out,
|
|
constraint_map::in, constraint_map::out,
|
|
list(hlds_constraint)::in, list(hlds_constraint)::out,
|
|
hlds_constraints::in, hlds_constraints::out, bool::out) is det.
|
|
|
|
apply_instance_rules(ClassTable, InstanceTable, !TVarSet, !Proofs,
|
|
!ConstraintMap, !Seen, !Constraints, Changed) :-
|
|
!.Constraints = constraints(Unproven0, Assumed, Redundant0),
|
|
apply_instance_rules_2(ClassTable, InstanceTable, !TVarSet, !Proofs,
|
|
!ConstraintMap, Redundant0, Redundant, !Seen,
|
|
Unproven0, Unproven, Changed),
|
|
!:Constraints = constraints(Unproven, Assumed, Redundant).
|
|
|
|
:- pred apply_instance_rules_2(class_table::in, instance_table::in,
|
|
tvarset::in, tvarset::out,
|
|
constraint_proof_map::in, constraint_proof_map::out,
|
|
constraint_map::in, constraint_map::out,
|
|
redundant_constraints::in, redundant_constraints::out,
|
|
list(hlds_constraint)::in, list(hlds_constraint)::out,
|
|
list(hlds_constraint)::in, list(hlds_constraint)::out, bool::out)
|
|
is det.
|
|
|
|
apply_instance_rules_2(_, _, !TVarSet, !Proofs, !ConstraintMap, !Redundant,
|
|
!Seen, [], [], no).
|
|
apply_instance_rules_2(ClassTable, InstanceTable, !TVarSet, !Proofs,
|
|
!ConstraintMap, !Redundant, !Seen, [C | Cs], Constraints,
|
|
Changed) :-
|
|
C = constraint(_, ClassName, Types),
|
|
list__length(Types, Arity),
|
|
map__lookup(InstanceTable, class_id(ClassName, Arity), Instances),
|
|
InitialTVarSet = !.TVarSet,
|
|
(
|
|
find_matching_instance_rule(Instances, C, !TVarSet, !Proofs,
|
|
NewConstraints0)
|
|
->
|
|
update_constraint_map(C, !ConstraintMap),
|
|
% Remove any constraints we've already seen.
|
|
% This ensures we don't get into an infinite loop.
|
|
list__filter(matches_no_constraint(!.Seen), NewConstraints0,
|
|
NewConstraints),
|
|
update_redundant_constraints(ClassTable, !.TVarSet,
|
|
NewConstraints, !Redundant),
|
|
% Put the new constraints at the front of the list
|
|
!:Seen = NewConstraints ++ !.Seen,
|
|
Changed1 = yes
|
|
;
|
|
% Put the old constraint at the front of the list
|
|
NewConstraints = [C],
|
|
!:TVarSet = InitialTVarSet,
|
|
Changed1 = no
|
|
),
|
|
apply_instance_rules_2(ClassTable, InstanceTable, !TVarSet, !Proofs,
|
|
!ConstraintMap, !Redundant, !Seen, Cs, TailConstraints,
|
|
Changed2),
|
|
bool__or(Changed1, Changed2, Changed),
|
|
list__append(NewConstraints, TailConstraints, Constraints).
|
|
|
|
:- pred matches_no_constraint(list(hlds_constraint)::in, hlds_constraint::in)
|
|
is semidet.
|
|
|
|
matches_no_constraint(Seen, Constraint) :-
|
|
\+ (some [S] (
|
|
list__member(S, Seen),
|
|
matching_constraints(S, Constraint)
|
|
)).
|
|
|
|
% We take the first matching instance rule that we can find; any
|
|
% overlapping instance declarations will have been caught earlier.
|
|
%
|
|
% This pred also catches tautological constraints since the
|
|
% NewConstraints will be [].
|
|
%
|
|
% XXX Surely we shouldn't need to rename the variables and return
|
|
% a new varset: this substitution should have been worked out before,
|
|
% as these varsets would already have been merged.
|
|
%
|
|
:- pred find_matching_instance_rule(list(hlds_instance_defn)::in,
|
|
hlds_constraint::in, tvarset::in, tvarset::out,
|
|
constraint_proof_map::in, constraint_proof_map::out,
|
|
list(hlds_constraint)::out) is semidet.
|
|
|
|
find_matching_instance_rule(Instances, Constraint, !TVarSet, !Proofs,
|
|
NewConstraints) :-
|
|
% Start a counter so we remember which instance decl we have used.
|
|
find_matching_instance_rule_2(Instances, 1, Constraint, !TVarSet,
|
|
!Proofs, NewConstraints).
|
|
|
|
:- pred find_matching_instance_rule_2(list(hlds_instance_defn)::in, int::in,
|
|
hlds_constraint::in, tvarset::in, tvarset::out,
|
|
constraint_proof_map::in, constraint_proof_map::out,
|
|
list(hlds_constraint)::out) is semidet.
|
|
|
|
find_matching_instance_rule_2([Instance | Instances], InstanceNum0, Constraint,
|
|
!TVarSet, !Proofs, NewConstraints) :-
|
|
Constraint = constraint(_Ids, _Name, Types),
|
|
ProgConstraints0 = Instance ^ instance_constraints,
|
|
InstanceTypes0 = Instance ^ instance_types,
|
|
InstanceTVarSet = Instance ^ instance_tvarset,
|
|
tvarset_merge_renaming(!.TVarSet, InstanceTVarSet, NewTVarSet,
|
|
Renaming),
|
|
apply_variable_renaming_to_type_list(Renaming, InstanceTypes0,
|
|
InstanceTypes),
|
|
(
|
|
type_list_subsumes(InstanceTypes, Types, Subst)
|
|
->
|
|
!:TVarSet = NewTVarSet,
|
|
apply_variable_renaming_to_prog_constraint_list(Renaming,
|
|
ProgConstraints0, ProgConstraints1),
|
|
apply_rec_subst_to_prog_constraint_list(Subst,
|
|
ProgConstraints1, ProgConstraints),
|
|
init_hlds_constraint_list(ProgConstraints, NewConstraints),
|
|
|
|
NewProof = apply_instance(InstanceNum0),
|
|
retrieve_prog_constraint(Constraint, ProgConstraint),
|
|
map__set(!.Proofs, ProgConstraint, NewProof, !:Proofs)
|
|
;
|
|
InstanceNum = InstanceNum0 + 1,
|
|
find_matching_instance_rule_2(Instances, InstanceNum,
|
|
Constraint, !TVarSet, !Proofs, NewConstraints)
|
|
).
|
|
|
|
% To reduce a constraint using class declarations, we search the
|
|
% superclass relation to find a path from the inferred constraint to
|
|
% another (declared or inferred) constraint.
|
|
%
|
|
:- pred apply_class_rules(superclass_table::in, tvarset::in, tvar_kind_map::in,
|
|
constraint_proof_map::in, constraint_proof_map::out,
|
|
constraint_map::in, constraint_map::out,
|
|
hlds_constraints::in, hlds_constraints::out, bool::out) is det.
|
|
|
|
apply_class_rules(SuperClassTable, TVarSet, KindMap, !Proofs, !ConstraintMap,
|
|
!Constraints, Changed) :-
|
|
!.Constraints = constraints(Unproven0, Assumed, _),
|
|
apply_class_rules_2(Assumed, SuperClassTable, TVarSet, KindMap,
|
|
!Proofs, !ConstraintMap, Unproven0, Unproven, Changed),
|
|
!:Constraints = !.Constraints ^ unproven := Unproven.
|
|
|
|
:- pred apply_class_rules_2(list(hlds_constraint)::in, superclass_table::in,
|
|
tvarset::in, tvar_kind_map::in, constraint_proof_map::in,
|
|
constraint_proof_map::out, constraint_map::in, constraint_map::out,
|
|
list(hlds_constraint)::in, list(hlds_constraint)::out,
|
|
bool::out) is det.
|
|
|
|
apply_class_rules_2(_, _, _, _, !Proofs, !ConstraintMap, [], [], no).
|
|
apply_class_rules_2(AssumedConstraints, SuperClassTable, TVarSet, KindMap,
|
|
!Proofs, !ConstraintMap, [Constraint0 | Constraints0],
|
|
Constraints, Changed) :-
|
|
Parents = [],
|
|
retrieve_prog_constraint(Constraint0, ProgConstraint0),
|
|
|
|
% The head_type_params argument contains all the variables from
|
|
% the original constraint that we are trying to prove. (These
|
|
% are the type variables that must not be bound as we search
|
|
% through the superclass relation).
|
|
%
|
|
constraint_get_tvars(ProgConstraint0, HeadTypeParams),
|
|
(
|
|
eliminate_constraint_by_class_rules(ProgConstraint0, _, _,
|
|
AssumedConstraints, SuperClassTable, HeadTypeParams,
|
|
TVarSet, KindMap, Parents, !Proofs)
|
|
->
|
|
update_constraint_map(Constraint0, !ConstraintMap),
|
|
apply_class_rules_2(AssumedConstraints, SuperClassTable,
|
|
TVarSet, KindMap, !Proofs, !ConstraintMap,
|
|
Constraints0, Constraints, _),
|
|
Changed = yes
|
|
;
|
|
apply_class_rules_2(AssumedConstraints, SuperClassTable,
|
|
TVarSet, KindMap, !Proofs, !ConstraintMap,
|
|
Constraints0, TailConstraints, Changed),
|
|
Constraints = [Constraint0 | TailConstraints]
|
|
).
|
|
|
|
% eliminate_constraint_by_class_rules eliminates a class constraint
|
|
% by applying the superclass relation. A list of "parent" constraints
|
|
% is also passed in --- these are the constraints that we are
|
|
% (recursively) in the process of checking, and is used to ensure that
|
|
% we don't get into a cycle in the relation.
|
|
%
|
|
:- pred eliminate_constraint_by_class_rules(prog_constraint::in,
|
|
prog_constraint::out, tsubst::out, list(hlds_constraint)::in,
|
|
superclass_table::in, head_type_params::in, tvarset::in,
|
|
tvar_kind_map::in, list(prog_constraint)::in,
|
|
constraint_proof_map::in, constraint_proof_map::out) is semidet.
|
|
|
|
eliminate_constraint_by_class_rules(C, SubstC, SubClassSubst,
|
|
AssumedConstraints, SuperClassTable, HeadTypeParams, TVarSet,
|
|
KindMap, ParentConstraints, Proofs0, Proofs) :-
|
|
|
|
% Make sure we aren't in a cycle in the
|
|
% superclass relation
|
|
\+ list__member(C, ParentConstraints),
|
|
|
|
C = constraint(SuperClassName, SuperClassTypes),
|
|
list__length(SuperClassTypes, SuperClassArity),
|
|
SuperClassId = class_id(SuperClassName, SuperClassArity),
|
|
multi_map__search(SuperClassTable, SuperClassId, SubClasses),
|
|
|
|
% Convert all the subclass_details into prog_constraints by
|
|
% doing the appropriate variable renaming and applying the
|
|
% type variable bindings.
|
|
% If the unification of the type variables for a particular
|
|
% constraint fails then that constraint is eliminated because it
|
|
% cannot contribute to proving the constraint we are trying to
|
|
% prove.
|
|
list__filter_map(
|
|
subclass_details_to_constraint(TVarSet, KindMap,
|
|
SuperClassTypes),
|
|
SubClasses, SubClassConstraints),
|
|
(
|
|
% Do the first level of search. We search for
|
|
% an assumed constraint which unifies with any
|
|
% of the subclass constraints.
|
|
varset__vars(TVarSet, XXXHeadTypeParams),
|
|
list.find_first_map(
|
|
match_assumed_constraint(XXXHeadTypeParams,
|
|
SubClassConstraints),
|
|
AssumedConstraints, SubClass - SubClassSubst0)
|
|
->
|
|
SubClassSubst = SubClassSubst0,
|
|
apply_rec_subst_to_prog_constraint(SubClassSubst, C, SubstC),
|
|
map__set(Proofs0, SubstC, superclass(SubClass), Proofs)
|
|
;
|
|
NewParentConstraints = [C | ParentConstraints],
|
|
|
|
% Recursively search the rest of the superclass
|
|
% relation.
|
|
SubClassSearch = (pred(Constraint::in, CnstrtAndProof::out)
|
|
is semidet :-
|
|
eliminate_constraint_by_class_rules(Constraint,
|
|
SubstConstraint, SubClassSubst0,
|
|
AssumedConstraints, SuperClassTable,
|
|
HeadTypeParams, TVarSet, KindMap,
|
|
NewParentConstraints, Proofs0, SubProofs),
|
|
CnstrtAndProof = {SubstConstraint, SubClassSubst0,
|
|
SubProofs}
|
|
),
|
|
% XXX this could (and should) be more efficient.
|
|
% (i.e. by manually doing a "cut").
|
|
find_first_map(SubClassSearch, SubClassConstraints,
|
|
{NewSubClass, SubClassSubst, NewProofs}),
|
|
apply_rec_subst_to_prog_constraint(SubClassSubst, C, SubstC),
|
|
map__set(NewProofs, SubstC, superclass(NewSubClass), Proofs)
|
|
).
|
|
|
|
:- pred match_assumed_constraint(head_type_params::in,
|
|
list(prog_constraint)::in, hlds_constraint::in,
|
|
pair(prog_constraint, tsubst)::out) is semidet.
|
|
|
|
match_assumed_constraint(HeadTypeParams, SubClassConstraints,
|
|
AssumedConstraint, Match) :-
|
|
find_first_map(
|
|
match_assumed_constraint_2(HeadTypeParams, AssumedConstraint),
|
|
SubClassConstraints, Match).
|
|
|
|
:- pred match_assumed_constraint_2(head_type_params::in, hlds_constraint::in,
|
|
prog_constraint::in, pair(prog_constraint, tsubst)::out) is semidet.
|
|
|
|
match_assumed_constraint_2(HeadTypeParams, AssumedConstraint,
|
|
SubClassConstraint, Match) :-
|
|
AssumedConstraint = constraint(_, AssumedConstraintClass,
|
|
AssumedConstraintTypes),
|
|
SubClassConstraint = constraint(AssumedConstraintClass,
|
|
SubClassConstraintTypes),
|
|
map__init(EmptySub),
|
|
type_unify_list(SubClassConstraintTypes, AssumedConstraintTypes,
|
|
HeadTypeParams, EmptySub, AssumedConstraintSub),
|
|
retrieve_prog_constraint(AssumedConstraint, MatchingProgConstraint),
|
|
Match = MatchingProgConstraint - AssumedConstraintSub.
|
|
|
|
% subclass_details_to_constraint will fail iff the call to
|
|
% type_unify_list fails.
|
|
%
|
|
:- pred subclass_details_to_constraint(tvarset::in, tvar_kind_map::in,
|
|
list(type)::in, subclass_details::in, prog_constraint::out) is semidet.
|
|
|
|
subclass_details_to_constraint(TVarSet, KindMap0, SuperClassTypes,
|
|
SubClassDetails, SubC) :-
|
|
SubClassDetails = subclass_details(SuperVars0, SubID, SubVars0,
|
|
SuperVarSet),
|
|
|
|
% Rename the variables from the typeclass
|
|
% declaration into those of the current pred.
|
|
tvarset_merge_renaming(TVarSet, SuperVarSet, _NewTVarSet, Renaming),
|
|
apply_variable_renaming_to_tvar_kind_map(Renaming, KindMap0, KindMap),
|
|
apply_variable_renaming_to_tvar_list(Renaming, SubVars0, SubVars),
|
|
apply_variable_renaming_to_type_list(Renaming, SuperVars0, SuperVars),
|
|
|
|
% Work out what the (renamed) vars from the
|
|
% typeclass declaration are bound to here.
|
|
type_unify_list(SuperVars, SuperClassTypes, [], map__init, Bindings),
|
|
SubID = class_id(SubName, _SubArity),
|
|
apply_rec_subst_to_tvar_list(KindMap, Bindings, SubVars,
|
|
SubClassTypes),
|
|
SubC = constraint(SubName, SubClassTypes).
|
|
|
|
% check_satisfiability(Constraints, HeadTypeParams):
|
|
% Check that all of the constraints are satisfiable.
|
|
% Fail if any are definitely not satisfiable.
|
|
%
|
|
% We disallow ground constraints
|
|
% for which there are no matching instance rules,
|
|
% even though the module system means that it would
|
|
% make sense to allow them: even if there
|
|
% is no instance declaration visible in the current
|
|
% module, there may be one visible in the caller.
|
|
% The reason we disallow them is that in practice
|
|
% allowing this causes type inference to let too
|
|
% many errors slip through, with the error diagnosis
|
|
% being too far removed from the real cause of the
|
|
% error. Note that ground constraints *are* allowed
|
|
% if you declare them, since we removed declared
|
|
% constraints before checking satisfiability.
|
|
%
|
|
% Similarly, for constraints on head type params
|
|
% (universally quantified type vars in this pred's type decl,
|
|
% or existentially quantified type vars in type decls for
|
|
% callees), we know that the head type params can never get bound.
|
|
% This means that if the constraint wasn't an assumed constraint
|
|
% and can't be eliminated by instance rule or class rule
|
|
% application, then we can report an error now, rather than
|
|
% later. (For non-head-type-param type variables,
|
|
% we need to wait, in case the type variable gets bound
|
|
% to a type for which there is a valid instance declaration.)
|
|
%
|
|
% So a constraint is considered satisfiable iff it
|
|
% contains at least one type variable that is not in the
|
|
% head type params.
|
|
%
|
|
:- pred check_satisfiability(list(hlds_constraint)::in, head_type_params::in)
|
|
is semidet.
|
|
|
|
check_satisfiability(Constraints, HeadTypeParams) :-
|
|
all [Constraint] (
|
|
list__member(Constraint, Constraints)
|
|
=>
|
|
(
|
|
Constraint = constraint(_Ids, _ClassName, Types),
|
|
type_list_contains_var(Types, TVar),
|
|
not list__member(TVar, HeadTypeParams)
|
|
)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
:- end_module check_hlds.typeclasses.
|
|
%-----------------------------------------------------------------------------%
|