mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-18 15:26:31 +00:00
fa9ca36d03
Estimated hours taken: 5 Branches: main This diff makes several files easier to read and to maintain (as well as more than 400 lines shorter), but contains no changes in algorithms whatsoever. compiler/deep_profiling.m: compiler/foreign.m: compiler/hlds_module.m: compiler/hlds_data.m: compiler/make_hlds.m: compiler/post_typecheck.m: compiler/prog_data.m: compiler/purity.m: compiler/type_util.m: Bring these modules into line with our current coding standards. Use predmode declarations and state variable syntax when appropriate. Reorder arguments of predicates where necessary for the use of state variable syntax, and where this improves readability. Replace predicates with functions where appropriate. Standardize indentation. compiler/*.m: Conform to the changes above.
907 lines
32 KiB
Mathematica
907 lines
32 KiB
Mathematica
%---------------------------------------------------------------------------%
|
|
% Copyright (C) 1996-2001, 2003 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.
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% This module checks conformance of instance declarations to the typeclass
|
|
% declaration.
|
|
%
|
|
% It does so by, for every method of every instance, generating a new pred
|
|
% whose types and modes are as expected by the typeclass declaration and
|
|
% whose body just calls the implementation provided by the instance
|
|
% declaration.
|
|
%
|
|
% eg. given the declarations:
|
|
%
|
|
% :- typeclass c(T) where [
|
|
% pred m(T::in, T::out) is semidet
|
|
% ].
|
|
%
|
|
% :- instance c(int) where [
|
|
% pred(m/2) is my_m
|
|
% ].
|
|
%
|
|
% The correctness of my_m/2 as an implementation of m/2 is checked by
|
|
% generating the new predicate:
|
|
%
|
|
% :- pred 'implementation of m/2'(int::in, int::out) is semidet.
|
|
%
|
|
% 'implementation of m/2'(HeadVar_1, HeadVar_2) :-
|
|
% my_m(HeadVar_1, HeadVar_2).
|
|
%
|
|
% By generating the new pred, we check the instance method for type, mode,
|
|
% determinism and uniqueness correctness since the generated pred is checked
|
|
% in each of those passes too.
|
|
%
|
|
% In addition, this pass checks that all superclass constraints are satisfied
|
|
% by the instance declaration.
|
|
%
|
|
% This pass fills in the super class proofs and instance method pred/proc ids
|
|
% in the instance table of the HLDS.
|
|
%
|
|
% Author: dgj.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- module check_hlds__check_typeclass.
|
|
|
|
:- interface.
|
|
|
|
:- import_module hlds__hlds_module.
|
|
:- import_module hlds__make_hlds.
|
|
|
|
:- import_module bool, io.
|
|
|
|
:- pred check_typeclass__check_instance_decls(module_info, qual_info,
|
|
module_info, qual_info, bool, io__state, io__state).
|
|
:- mode check_typeclass__check_instance_decls(in, in, out, out,
|
|
out, di, uo) is det.
|
|
|
|
:- implementation.
|
|
|
|
:- import_module backend_libs__base_typeclass_info.
|
|
:- import_module check_hlds__inst_match.
|
|
:- import_module check_hlds__mode_util.
|
|
:- import_module check_hlds__type_util.
|
|
:- import_module check_hlds__typecheck.
|
|
:- import_module hlds__error_util.
|
|
:- import_module hlds__hlds_data.
|
|
:- import_module hlds__hlds_goal.
|
|
:- import_module hlds__hlds_out.
|
|
:- import_module hlds__hlds_pred.
|
|
:- import_module libs__globals.
|
|
:- import_module libs__options.
|
|
:- import_module parse_tree__mercury_to_mercury.
|
|
:- import_module parse_tree__prog_data.
|
|
:- import_module parse_tree__prog_out.
|
|
:- import_module parse_tree__prog_util.
|
|
|
|
:- import_module int, string.
|
|
:- import_module list, assoc_list, map, set, term, varset.
|
|
:- import_module std_util, require.
|
|
|
|
:- type error_message == pair(prog_context, list(format_component)).
|
|
:- type error_messages == list(error_message).
|
|
|
|
check_typeclass__check_instance_decls(ModuleInfo0, QualInfo0,
|
|
ModuleInfo, QualInfo, FoundError, !IO) :-
|
|
module_info_classes(ModuleInfo0, ClassTable),
|
|
module_info_instances(ModuleInfo0, InstanceTable0),
|
|
map__to_assoc_list(InstanceTable0, InstanceList0),
|
|
list_map_foldl2(check_one_class(ClassTable), InstanceList0,
|
|
InstanceList, check_tc_info([], ModuleInfo0, QualInfo0),
|
|
check_tc_info(Errors, ModuleInfo1, QualInfo), !IO),
|
|
(
|
|
Errors = []
|
|
->
|
|
map__from_assoc_list(InstanceList, InstanceTable),
|
|
module_info_set_instances(InstanceTable,
|
|
ModuleInfo1, ModuleInfo),
|
|
FoundError = no
|
|
;
|
|
ModuleInfo = ModuleInfo1,
|
|
list__reverse(Errors, ErrorList),
|
|
WriteError = (pred(E::in, IO0::di, IO::uo) is det :-
|
|
E = ErrorContext - ErrorPieces,
|
|
write_error_pieces(ErrorContext, 0, ErrorPieces,
|
|
IO0, IO)
|
|
),
|
|
list__foldl(WriteError, ErrorList, !IO),
|
|
io__set_exit_status(1, !IO),
|
|
FoundError = yes
|
|
).
|
|
|
|
:- type check_tc_info
|
|
---> check_tc_info(
|
|
error_messages :: error_messages,
|
|
module_info :: module_info,
|
|
qual_info :: qual_info
|
|
).
|
|
|
|
% list__map_foldl2(Pred, InList, OutList, StartA, EndA, StartB, EndB)
|
|
% calls Pred with two accumulator (with the initial values of
|
|
% StartA and StartB respectively) on each element of InList
|
|
% (working left-to-right) to transform InList into OutList.
|
|
% The final values of the accumulators are returned in EndA
|
|
% and EndB respectively.
|
|
:- pred list_map_foldl2(pred(X, Y, Z, Z, W, W), list(X), list(Y), Z, Z, W, W).
|
|
:- mode list_map_foldl2(pred(in, out, in, out, di, uo) is det,
|
|
in, out, in, out, di, uo) is det.
|
|
|
|
list_map_foldl2(_, [], [], A, A) -->
|
|
[].
|
|
list_map_foldl2(P, [H0|T0], [H|T], A0, A) -->
|
|
call(P, H0, H, A0, A1),
|
|
list_map_foldl2(P, T0, T, A1, A).
|
|
|
|
% check all the instances of one class.
|
|
:- pred check_one_class(class_table,
|
|
pair(class_id, list(hlds_instance_defn)),
|
|
pair(class_id, list(hlds_instance_defn)),
|
|
check_tc_info, check_tc_info,
|
|
io__state, io__state).
|
|
:- mode check_one_class(in, in, out, in, out, di, uo) is det.
|
|
|
|
check_one_class(ClassTable, ClassId - InstanceDefns0,
|
|
ClassId - InstanceDefns, CheckTCInfo0, CheckTCInfo, IO0, IO) :-
|
|
|
|
map__lookup(ClassTable, ClassId, ClassDefn),
|
|
ClassDefn = hlds_class_defn(ImportStatus, SuperClasses, ClassVars,
|
|
Interface, ClassInterface, ClassVarSet, TermContext),
|
|
|
|
(
|
|
status_defined_in_this_module(ImportStatus, yes),
|
|
Interface = abstract
|
|
->
|
|
ClassId = class_id(ClassName, ClassArity),
|
|
sym_name_and_arity_to_string(ClassName / ClassArity,
|
|
ClassNameStr),
|
|
ErrorPieces = [
|
|
words("Error: no definition for typeclass"),
|
|
words(string__append_list(["`", ClassNameStr, "'."]))
|
|
],
|
|
|
|
Messages0 = CheckTCInfo0 ^ error_messages,
|
|
CheckTCInfo = CheckTCInfo0 ^ error_messages :=
|
|
[TermContext - ErrorPieces | Messages0],
|
|
InstanceDefns = InstanceDefns0,
|
|
IO = IO0
|
|
;
|
|
solutions(
|
|
(pred(PredId::out) is nondet :-
|
|
list__member(ClassProc, ClassInterface),
|
|
ClassProc = hlds_class_proc(PredId, _)
|
|
),
|
|
PredIds),
|
|
list_map_foldl2(
|
|
check_class_instance(ClassId, SuperClasses,
|
|
ClassVars, ClassInterface, Interface,
|
|
ClassVarSet, PredIds),
|
|
InstanceDefns0, InstanceDefns,
|
|
CheckTCInfo0, CheckTCInfo,
|
|
IO0, IO)
|
|
).
|
|
|
|
% check one instance of one class
|
|
:- pred check_class_instance(class_id, list(class_constraint), list(tvar),
|
|
hlds_class_interface, class_interface, tvarset, list(pred_id),
|
|
hlds_instance_defn, hlds_instance_defn,
|
|
check_tc_info, check_tc_info,
|
|
io__state, io__state).
|
|
:- mode check_class_instance(in, in, in, in, in, in, in, in, out, in, out,
|
|
di, uo) is det.
|
|
|
|
check_class_instance(ClassId, SuperClasses, Vars, HLDSClassInterface,
|
|
ClassInterface, ClassVarSet, PredIds, InstanceDefn0,
|
|
InstanceDefn,
|
|
check_tc_info(Errors0, ModuleInfo0, QualInfo0),
|
|
check_tc_info(Errors, ModuleInfo, QualInfo),
|
|
IO0, IO):-
|
|
|
|
% check conformance of the instance body
|
|
InstanceDefn0 = hlds_instance_defn(_, _, TermContext, _, _,
|
|
InstanceBody, _, _, _),
|
|
(
|
|
InstanceBody = abstract,
|
|
InstanceDefn2 = InstanceDefn0,
|
|
ModuleInfo1 = ModuleInfo0,
|
|
QualInfo = QualInfo0,
|
|
Errors2 = Errors0,
|
|
IO = IO0
|
|
;
|
|
InstanceBody = concrete(InstanceMethods),
|
|
(
|
|
ClassInterface = abstract,
|
|
ClassId = class_id(ClassName, ClassArity),
|
|
sym_name_and_arity_to_string(ClassName / ClassArity,
|
|
ClassNameStr),
|
|
ErrorPieces = [
|
|
words("Error: instance declaration for"),
|
|
words("abstract typeclass"),
|
|
words(string__append_list(["`", ClassNameStr, "'."]))
|
|
],
|
|
Errors2 = [TermContext - ErrorPieces | Errors0],
|
|
InstanceDefn2 = InstanceDefn0,
|
|
ModuleInfo1 = ModuleInfo0,
|
|
QualInfo = QualInfo0,
|
|
IO = IO0
|
|
;
|
|
ClassInterface = concrete(_),
|
|
InstanceCheckInfo0 = instance_check_info(InstanceDefn0,
|
|
[], Errors0, ModuleInfo0, QualInfo0),
|
|
list__foldl2(
|
|
check_instance_pred(ClassId, Vars, HLDSClassInterface),
|
|
PredIds, InstanceCheckInfo0, InstanceCheckInfo,
|
|
IO0, IO),
|
|
InstanceCheckInfo = instance_check_info(InstanceDefn1,
|
|
RevInstanceMethods, Errors1, ModuleInfo1,
|
|
QualInfo),
|
|
|
|
%
|
|
% We need to make sure that the MaybePredProcs field is
|
|
% set to yes(_) after this pass. Normally that will be
|
|
% handled by check_instance_pred, but we also need to handle
|
|
% it below, in case the class has no methods.
|
|
%
|
|
InstanceDefn1 = hlds_instance_defn(A, B, C, D, E, _,
|
|
MaybePredProcs1, H, I),
|
|
(
|
|
MaybePredProcs1 = yes(_),
|
|
MaybePredProcs = MaybePredProcs1
|
|
;
|
|
MaybePredProcs1 = no,
|
|
MaybePredProcs = yes([])
|
|
),
|
|
|
|
%
|
|
% Make sure the list of instance methods is in the same
|
|
% order as the methods in the class definition. intermod.m
|
|
% relies on this
|
|
OrderedInstanceMethods = list__reverse(RevInstanceMethods),
|
|
|
|
InstanceDefn2 = hlds_instance_defn(A, B, C, D, E,
|
|
concrete(OrderedInstanceMethods),
|
|
MaybePredProcs, H, I),
|
|
|
|
%
|
|
% Check if there are any instance methods left over,
|
|
% which did not match any of the methods from the
|
|
% class interface.
|
|
%
|
|
InstanceDefn2 = hlds_instance_defn(_, _, Context,
|
|
_, _, _, _, _, _),
|
|
check_for_bogus_methods(InstanceMethods, ClassId, PredIds,
|
|
Context, ModuleInfo1, Errors1, Errors2)
|
|
)
|
|
),
|
|
|
|
% check that the superclass constraints are satisfied for the
|
|
% types in this instance declaration
|
|
check_superclass_conformance(ClassId, SuperClasses, Vars, ClassVarSet,
|
|
InstanceDefn2, InstanceDefn,
|
|
Errors2 - ModuleInfo1, Errors - ModuleInfo).
|
|
|
|
%
|
|
% Check if there are any instance methods left over,
|
|
% which did not match any of the methods from the
|
|
% class interface. If so, add an appropriate error
|
|
% message to the list of error messages.
|
|
%
|
|
:- pred check_for_bogus_methods(list(instance_method), class_id, list(pred_id),
|
|
prog_context, module_info, error_messages, error_messages).
|
|
:- mode check_for_bogus_methods(in, in, in, in, in, in, out) is det.
|
|
|
|
check_for_bogus_methods(InstanceMethods, ClassId, ClassPredIds, Context,
|
|
ModuleInfo1, Errors0, Errors) :-
|
|
module_info_get_predicate_table(ModuleInfo1, PredTable),
|
|
DefnIsOK = (pred(Method::in) is semidet :-
|
|
% Find this method definition's p/f, name, arity
|
|
Method = instance_method(MethodPredOrFunc,
|
|
MethodName, _MethodDefn,
|
|
MethodArity, _Context),
|
|
% Search for pred_ids matching that p/f, name, arity,
|
|
% and succeed if the method definition p/f, name, and
|
|
% arity matches at least one of the methods from the
|
|
% class interface
|
|
adjust_func_arity(MethodPredOrFunc, MethodArity,
|
|
MethodPredArity),
|
|
predicate_table_search_pf_sym_arity(PredTable,
|
|
is_fully_qualified, MethodPredOrFunc,
|
|
MethodName, MethodPredArity, MatchingPredIds),
|
|
some [PredId] (
|
|
list__member(PredId, MatchingPredIds),
|
|
list__member(PredId, ClassPredIds)
|
|
)
|
|
),
|
|
list__filter(DefnIsOK, InstanceMethods, _OKInstanceMethods,
|
|
BogusInstanceMethods),
|
|
(
|
|
BogusInstanceMethods = []
|
|
->
|
|
Errors = Errors0
|
|
;
|
|
%
|
|
% There were one or more bogus methods.
|
|
% Construct an appropriate error message.
|
|
%
|
|
ClassId = class_id(ClassName, ClassArity),
|
|
prog_out__sym_name_to_string(ClassName,
|
|
ClassNameString),
|
|
string__int_to_string(ClassArity, ClassArityString),
|
|
string__append_list([
|
|
"In instance declaration for `",
|
|
ClassNameString, "/", ClassArityString, "': ",
|
|
"incorrect method name(s): "],
|
|
ErrorMsgStart),
|
|
BogusInstanceMethodNames = list__map(format_method_name,
|
|
BogusInstanceMethods),
|
|
error_util__list_to_pieces(BogusInstanceMethodNames,
|
|
ErrorMsgBody0),
|
|
ErrorMsgBody = list__append(ErrorMsgBody0, [words(".")]),
|
|
NewError = Context - [words(ErrorMsgStart) | ErrorMsgBody],
|
|
Errors = [NewError | Errors0]
|
|
).
|
|
|
|
:- func format_method_name(instance_method) = string.
|
|
format_method_name(Method) = StringName :-
|
|
Method = instance_method(PredOrFunc, Name, _Defn, Arity, _Context),
|
|
adjust_func_arity(PredOrFunc, Arity, PredArity),
|
|
hlds_out__simple_call_id_to_string(
|
|
PredOrFunc - Name/PredArity, StringName).
|
|
|
|
%----------------------------------------------------------------------------%
|
|
|
|
:- type instance_check_info
|
|
---> instance_check_info(
|
|
hlds_instance_defn,
|
|
instance_methods, % The instance methods in reverse
|
|
% order of the methods in the class
|
|
% declaration.
|
|
error_messages,
|
|
module_info,
|
|
qual_info
|
|
).
|
|
|
|
% This structure holds the information about a particular instance
|
|
% method
|
|
:- type instance_method_info ---> instance_method_info(
|
|
module_info,
|
|
qual_info,
|
|
sym_name, % Name that the
|
|
% introduced pred
|
|
% should be given.
|
|
arity, % Arity of the method.
|
|
% (For funcs, this is
|
|
% the original arity,
|
|
% not the arity as a
|
|
% predicate.)
|
|
existq_tvars, % Existentially quant.
|
|
% type variables
|
|
list(type), % Expected types of
|
|
% arguments.
|
|
class_constraints, % Constraints from
|
|
% class method.
|
|
list(modes_and_detism), % Modes and
|
|
% determinisms of the
|
|
% required procs.
|
|
error_messages, % Error messages
|
|
% that have been
|
|
% generated.
|
|
tvarset,
|
|
import_status, % Import status of
|
|
% instance decl.
|
|
pred_or_func % Is method pred or
|
|
% func?
|
|
).
|
|
|
|
%----------------------------------------------------------------------------%
|
|
|
|
% check one pred in one instance of one class
|
|
:- pred check_instance_pred(class_id, list(tvar), hlds_class_interface,
|
|
pred_id, instance_check_info, instance_check_info,
|
|
io__state, io__state).
|
|
:- mode check_instance_pred(in,in, in, in, in, out, di, uo) is det.
|
|
|
|
check_instance_pred(ClassId, ClassVars, ClassInterface, PredId,
|
|
InstanceCheckInfo0, InstanceCheckInfo, IO0, IO) :-
|
|
|
|
InstanceCheckInfo0 = instance_check_info(InstanceDefn0,
|
|
OrderedMethods0, Errors0, ModuleInfo0,
|
|
QualInfo0),
|
|
solutions((pred(ProcId::out) is nondet :-
|
|
list__member(ClassProc, ClassInterface),
|
|
ClassProc = hlds_class_proc(PredId, ProcId)
|
|
), ProcIds),
|
|
module_info_pred_info(ModuleInfo0, PredId, PredInfo),
|
|
pred_info_arg_types(PredInfo, ArgTypeVars, ExistQVars, ArgTypes),
|
|
pred_info_get_class_context(PredInfo, ClassContext0),
|
|
pred_info_get_markers(PredInfo, Markers0),
|
|
remove_marker(class_method, Markers0, Markers),
|
|
% The first constraint in the class context of a class method
|
|
% is always the constraint for the class of which it is
|
|
% a member. Seeing that we are checking an instance
|
|
% declaration, we don't check that constraint... the instance
|
|
% declaration itself satisfies it!
|
|
(
|
|
ClassContext0 = constraints([_|OtherUnivCs], ExistCs)
|
|
->
|
|
UnivCs = OtherUnivCs,
|
|
ClassContext = constraints(UnivCs, ExistCs)
|
|
;
|
|
error("check_instance_pred: no constraint on class method")
|
|
),
|
|
|
|
MethodName0 = pred_info_name(PredInfo),
|
|
PredModule = pred_info_module(PredInfo),
|
|
MethodName = qualified(PredModule, MethodName0),
|
|
PredArity = pred_info_arity(PredInfo),
|
|
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
|
|
adjust_func_arity(PredOrFunc, Arity, PredArity),
|
|
pred_info_procedures(PredInfo, ProcTable),
|
|
list__map((pred(TheProcId::in, ModesAndDetism::out) is det :-
|
|
map__lookup(ProcTable, TheProcId, ProcInfo),
|
|
proc_info_argmodes(ProcInfo, Modes),
|
|
% if the determinism declaration on the method
|
|
% was omitted, then make_hlds.m will have
|
|
% already issued an error message, so
|
|
% don't complain here.
|
|
proc_info_declared_determinism(ProcInfo,
|
|
MaybeDetism),
|
|
proc_info_inst_varset(ProcInfo, InstVarSet),
|
|
ModesAndDetism = modes_and_detism(Modes,
|
|
InstVarSet, MaybeDetism)
|
|
), ProcIds, ArgModes),
|
|
|
|
InstanceDefn0 = hlds_instance_defn(_, Status, _, _, InstanceTypes,
|
|
_, _, _, _),
|
|
|
|
% Work out the name of the predicate that we will generate
|
|
% to check this instance method.
|
|
make_introduced_pred_name(ClassId, MethodName, Arity,
|
|
InstanceTypes, PredName),
|
|
|
|
Info0 = instance_method_info(ModuleInfo0, QualInfo0, PredName,
|
|
Arity, ExistQVars, ArgTypes, ClassContext, ArgModes,
|
|
Errors0, ArgTypeVars, Status, PredOrFunc),
|
|
|
|
check_instance_pred_procs(ClassId, ClassVars, MethodName, Markers,
|
|
InstanceDefn0, InstanceDefn, OrderedMethods0, OrderedMethods,
|
|
Info0, Info, IO0, IO),
|
|
|
|
Info = instance_method_info(ModuleInfo, QualInfo, _PredName,
|
|
_Arity, _ExistQVars, _ArgTypes, _ClassContext, _ArgModes,
|
|
Errors, _ArgTypeVars, _Status, _PredOrFunc),
|
|
|
|
InstanceCheckInfo = instance_check_info(InstanceDefn,
|
|
OrderedMethods, Errors, ModuleInfo, QualInfo).
|
|
|
|
:- type modes_and_detism
|
|
---> modes_and_detism(list(mode), inst_varset, maybe(determinism)).
|
|
|
|
:- pred check_instance_pred_procs(class_id::in, list(tvar)::in, sym_name::in,
|
|
pred_markers::in, hlds_instance_defn::in, hlds_instance_defn::out,
|
|
instance_methods::in, instance_methods::out,
|
|
instance_method_info::in, instance_method_info::out,
|
|
io::di, io::uo) is det.
|
|
|
|
check_instance_pred_procs(ClassId, ClassVars, MethodName, Markers,
|
|
InstanceDefn0, InstanceDefn, OrderedInstanceMethods0,
|
|
OrderedInstanceMethods, Info0, Info, !IO) :-
|
|
InstanceDefn0 = hlds_instance_defn(InstanceModuleName, B,
|
|
InstanceContext, InstanceConstraints, InstanceTypes,
|
|
InstanceBody, MaybeInstancePredProcs, InstanceVarSet, I),
|
|
Info0 = instance_method_info(ModuleInfo, QualInfo, PredName, Arity,
|
|
ExistQVars, ArgTypes, ClassContext, ArgModes, Errors0,
|
|
ArgTypeVars, Status, PredOrFunc),
|
|
get_matching_instance_defns(InstanceBody, PredOrFunc, MethodName,
|
|
Arity, MatchingInstanceMethods),
|
|
(
|
|
MatchingInstanceMethods = [InstanceMethod]
|
|
->
|
|
OrderedInstanceMethods =
|
|
[InstanceMethod | OrderedInstanceMethods0],
|
|
InstanceMethod = instance_method(_, _, InstancePredDefn,
|
|
_, Context),
|
|
produce_auxiliary_procs(ClassId, ClassVars, Markers,
|
|
InstanceTypes, InstanceConstraints,
|
|
InstanceVarSet, InstanceModuleName,
|
|
InstancePredDefn, Context,
|
|
InstancePredId, InstanceProcIds, Info0, Info, !IO),
|
|
|
|
MakeClassProc = (pred(TheProcId::in, PredProcId::out) is det :-
|
|
PredProcId = hlds_class_proc(InstancePredId,
|
|
TheProcId)
|
|
),
|
|
list__map(MakeClassProc, InstanceProcIds, InstancePredProcs1),
|
|
(
|
|
MaybeInstancePredProcs = yes(InstancePredProcs0),
|
|
list__append(InstancePredProcs0,
|
|
InstancePredProcs1, InstancePredProcs)
|
|
;
|
|
MaybeInstancePredProcs = no,
|
|
InstancePredProcs = InstancePredProcs1
|
|
),
|
|
InstanceDefn = hlds_instance_defn(InstanceModuleName, B,
|
|
Context, InstanceConstraints, InstanceTypes,
|
|
InstanceBody, yes(InstancePredProcs), InstanceVarSet, I)
|
|
;
|
|
MatchingInstanceMethods = [I1, I2 | Is]
|
|
->
|
|
%
|
|
% duplicate method definition error
|
|
%
|
|
OrderedInstanceMethods = OrderedInstanceMethods0,
|
|
InstanceDefn = InstanceDefn0,
|
|
ClassId = class_id(ClassName, _ClassArity),
|
|
prog_out__sym_name_to_string(MethodName, MethodNameString),
|
|
prog_out__sym_name_to_string(ClassName, ClassNameString),
|
|
pred_or_func_to_string(PredOrFunc, PredOrFuncString),
|
|
string__int_to_string(Arity, ArityString),
|
|
InstanceTypesString = mercury_type_list_to_string(
|
|
InstanceVarSet, InstanceTypes),
|
|
string__append_list([
|
|
"In instance declaration for `",
|
|
ClassNameString, "(", InstanceTypesString, ")': ",
|
|
"multiple implementations of type class ",
|
|
PredOrFuncString, " method `",
|
|
MethodNameString, "/", ArityString, "'."],
|
|
ErrorHeader),
|
|
I1 = instance_method(_, _, _, _, I1Context),
|
|
Heading =
|
|
[I1Context - [words("First definition appears here.")],
|
|
InstanceContext - [words(ErrorHeader)]],
|
|
list__map((pred(Definition::in, ContextAndError::out) is det :-
|
|
Definition = instance_method(_, _, _, _, TheContext),
|
|
Error = [words("Subsequent definition appears here.")],
|
|
ContextAndError = TheContext - Error
|
|
), [I2 | Is], SubsequentErrors),
|
|
|
|
% errors are built up in reverse.
|
|
list__append(SubsequentErrors, Heading, NewErrors),
|
|
list__append(NewErrors, Errors0, Errors),
|
|
Info = instance_method_info(ModuleInfo, QualInfo, PredName,
|
|
Arity, ExistQVars, ArgTypes, ClassContext,
|
|
ArgModes, Errors, ArgTypeVars, Status, PredOrFunc)
|
|
;
|
|
%
|
|
% undefined method error
|
|
%
|
|
OrderedInstanceMethods = OrderedInstanceMethods0,
|
|
InstanceDefn = InstanceDefn0,
|
|
ClassId = class_id(ClassName, _ClassArity),
|
|
prog_out__sym_name_to_string(MethodName, MethodNameString),
|
|
prog_out__sym_name_to_string(ClassName, ClassNameString),
|
|
pred_or_func_to_string(PredOrFunc, PredOrFuncString),
|
|
string__int_to_string(Arity, ArityString),
|
|
InstanceTypesString = mercury_type_list_to_string(
|
|
InstanceVarSet, InstanceTypes),
|
|
string__append_list([
|
|
"In instance declaration for `",
|
|
ClassNameString, "(", InstanceTypesString, ")': ",
|
|
"no implementation for type class ",
|
|
PredOrFuncString, " method `",
|
|
MethodNameString, "/", ArityString, "'."],
|
|
NewError),
|
|
Errors = [InstanceContext - [words(NewError)] | Errors0],
|
|
Info = instance_method_info(ModuleInfo, QualInfo, PredName,
|
|
Arity, ExistQVars, ArgTypes, ClassContext,
|
|
ArgModes, Errors,
|
|
ArgTypeVars, Status, PredOrFunc)
|
|
).
|
|
|
|
%
|
|
% Get all the instance definitions which match the specified
|
|
% predicate/function name/arity, with multiple clause definitions
|
|
% being combined into a single definition.
|
|
%
|
|
:- pred get_matching_instance_defns(instance_body, pred_or_func,
|
|
sym_name, arity, list(instance_method)).
|
|
:- mode get_matching_instance_defns(in, in, in, in, out) is det.
|
|
|
|
get_matching_instance_defns(abstract, _, _, _, []).
|
|
get_matching_instance_defns(concrete(InstanceMethods), PredOrFunc, MethodName,
|
|
MethodArity, ResultList) :-
|
|
%
|
|
% First find the instance method definitions that match this
|
|
% predicate/function's name and arity
|
|
%
|
|
list__filter(
|
|
(pred(Method::in) is semidet :-
|
|
Method = instance_method(PredOrFunc,
|
|
MethodName, _MethodDefn,
|
|
MethodArity, _Context)
|
|
),
|
|
InstanceMethods, MatchingMethods),
|
|
(
|
|
MatchingMethods = [First, _Second | _],
|
|
First = instance_method(_, _, _, _, FirstContext),
|
|
\+ (
|
|
list__member(DefnViaName, MatchingMethods),
|
|
DefnViaName = instance_method(_, _, name(_), _, _)
|
|
)
|
|
->
|
|
%
|
|
% If all of the instance method definitions for this
|
|
% pred/func are clauses, and there are more than one
|
|
% of them, then we must combine them all into a
|
|
% single definition.
|
|
%
|
|
MethodToClause = (pred(Method::in, Clauses::out) is semidet :-
|
|
Method = instance_method(_, _, Defn, _, _),
|
|
Defn = clauses(Clauses)),
|
|
list__filter_map(MethodToClause, MatchingMethods, ClausesList),
|
|
list__condense(ClausesList, FlattenedClauses),
|
|
CombinedMethod = instance_method(PredOrFunc,
|
|
MethodName, clauses(FlattenedClauses),
|
|
MethodArity, FirstContext),
|
|
ResultList = [CombinedMethod]
|
|
;
|
|
%
|
|
% If there are less than two matching method definitions,
|
|
% or if any of the instance method definitions is a method
|
|
% name, then we're done.
|
|
%
|
|
ResultList = MatchingMethods
|
|
).
|
|
|
|
:- pred pred_or_func_to_string(pred_or_func::in, string::out) is det.
|
|
|
|
pred_or_func_to_string(predicate, "predicate").
|
|
pred_or_func_to_string(function, "function").
|
|
|
|
:- pred produce_auxiliary_procs(class_id::in, list(tvar)::in, pred_markers::in,
|
|
list(type)::in, list(class_constraint)::in, tvarset::in,
|
|
module_name::in, instance_proc_def::in, prog_context::in,
|
|
pred_id::out, list(proc_id)::out,
|
|
instance_method_info::in, instance_method_info::out,
|
|
io::di, io::uo) is det.
|
|
|
|
produce_auxiliary_procs(ClassId, ClassVars, Markers0,
|
|
InstanceTypes0, InstanceConstraints0, InstanceVarSet,
|
|
InstanceModuleName, InstancePredDefn, Context, PredId,
|
|
InstanceProcIds, Info0, Info, !IO) :-
|
|
|
|
Info0 = instance_method_info(ModuleInfo0, QualInfo0, PredName,
|
|
Arity, ExistQVars0, ArgTypes0, ClassMethodClassContext0,
|
|
ArgModes, Errors, ArgTypeVars0, Status0, PredOrFunc),
|
|
|
|
% Rename the instance variables apart from the class variables
|
|
varset__merge_subst(ArgTypeVars0, InstanceVarSet, ArgTypeVars1,
|
|
RenameSubst),
|
|
term__apply_substitution_to_list(InstanceTypes0, RenameSubst,
|
|
InstanceTypes1),
|
|
apply_subst_to_constraint_list(RenameSubst, InstanceConstraints0,
|
|
InstanceConstraints1),
|
|
|
|
% Work out what the type variables are bound to for this
|
|
% instance, and update the class types appropriately.
|
|
map__from_corresponding_lists(ClassVars, InstanceTypes1, TypeSubst),
|
|
term__apply_substitution_to_list(ArgTypes0, TypeSubst, ArgTypes1),
|
|
apply_subst_to_constraints(TypeSubst, ClassMethodClassContext0,
|
|
ClassMethodClassContext1),
|
|
|
|
% Get rid of any unwanted type variables
|
|
term__vars_list(ArgTypes1, VarsToKeep0),
|
|
list__sort_and_remove_dups(VarsToKeep0, VarsToKeep),
|
|
varset__squash(ArgTypeVars1, VarsToKeep, ArgTypeVars, SquashSubst),
|
|
term__apply_variable_renaming_to_list(ArgTypes1, SquashSubst,
|
|
ArgTypes),
|
|
apply_variable_renaming_to_constraints(SquashSubst,
|
|
ClassMethodClassContext1, ClassMethodClassContext),
|
|
apply_partial_map_to_list(ExistQVars0, SquashSubst, ExistQVars),
|
|
apply_variable_renaming_to_list(InstanceTypes1, SquashSubst,
|
|
InstanceTypes),
|
|
apply_variable_renaming_to_constraint_list(SquashSubst,
|
|
InstanceConstraints1, InstanceConstraints),
|
|
|
|
% Add the constraints from the instance declaration to the
|
|
% constraints from the class method. This allows an instance
|
|
% method to have constraints on it which are not part of the
|
|
% instance declaration as a whole.
|
|
ClassMethodClassContext = constraints(UnivConstraints1,
|
|
ExistConstraints),
|
|
list__append(InstanceConstraints, UnivConstraints1, UnivConstraints),
|
|
ClassContext = constraints(UnivConstraints, ExistConstraints),
|
|
|
|
% Introduce a new predicate which calls the implementation
|
|
% given in the instance declaration.
|
|
Cond = true,
|
|
map__init(Proofs),
|
|
add_marker(class_instance_method, Markers0, Markers1),
|
|
( InstancePredDefn = name(_) ->
|
|
% For instance methods which are defined using the named
|
|
% syntax (e.g. "pred(...) is ...") rather than the clauses
|
|
% syntax, we record an additional marker; the only effect
|
|
% of this marker is that we output slightly different
|
|
% error messages for such predicates.
|
|
add_marker(named_class_instance_method, Markers1, Markers)
|
|
;
|
|
Markers = Markers1
|
|
),
|
|
module_info_globals(ModuleInfo0, Globals),
|
|
globals__lookup_string_option(Globals, aditi_user, User),
|
|
|
|
( status_is_imported(Status0, yes) ->
|
|
Status = opt_imported
|
|
;
|
|
Status = Status0
|
|
),
|
|
|
|
adjust_func_arity(PredOrFunc, Arity, PredArity),
|
|
produce_instance_method_clauses(InstancePredDefn, PredOrFunc,
|
|
PredArity, ArgTypes, Markers, Context, Status, ClausesInfo,
|
|
ModuleInfo0, ModuleInfo1, QualInfo0, QualInfo, !IO),
|
|
|
|
pred_info_init(InstanceModuleName, PredName, PredArity, ArgTypeVars,
|
|
ExistQVars, ArgTypes, Cond, Context, ClausesInfo, Status,
|
|
Markers, none, PredOrFunc, ClassContext, Proofs, User,
|
|
PredInfo0),
|
|
pred_info_set_clauses_info(ClausesInfo, PredInfo0, PredInfo1),
|
|
|
|
% Fill in some information in the pred_info which is
|
|
% used by polymorphism to make sure the type-infos
|
|
% and typeclass-infos are added in the correct order.
|
|
MethodConstraints = instance_method_constraints(ClassId,
|
|
InstanceTypes, InstanceConstraints,
|
|
ClassMethodClassContext),
|
|
pred_info_set_maybe_instance_method_constraints(
|
|
yes(MethodConstraints), PredInfo1, PredInfo2),
|
|
|
|
% Add procs with the expected modes and determinisms
|
|
AddProc = (pred(ModeAndDet::in, NewProcId::out,
|
|
OldPredInfo::in, NewPredInfo::out) is det :-
|
|
ModeAndDet = modes_and_detism(Modes, InstVarSet, MaybeDet),
|
|
add_new_proc(InstVarSet, PredArity, Modes, yes(Modes), no,
|
|
MaybeDet, Context, address_is_taken,
|
|
OldPredInfo, NewPredInfo, NewProcId)
|
|
),
|
|
list__map_foldl(AddProc, ArgModes, InstanceProcIds,
|
|
PredInfo2, PredInfo),
|
|
|
|
module_info_get_predicate_table(ModuleInfo1, PredicateTable1),
|
|
module_info_get_partial_qualifier_info(ModuleInfo1, PQInfo),
|
|
% XXX why do we need to pass may_be_unqualified here,
|
|
% rather than passing must_be_qualified or calling the /4 version?
|
|
predicate_table_insert(PredInfo, may_be_unqualified, PQInfo,
|
|
PredId, PredicateTable1, PredicateTable),
|
|
module_info_set_predicate_table(PredicateTable,
|
|
ModuleInfo1, ModuleInfo),
|
|
|
|
Info = instance_method_info(ModuleInfo, QualInfo, PredName, Arity,
|
|
ExistQVars, ArgTypes, ClassContext, ArgModes, Errors,
|
|
ArgTypeVars, Status, PredOrFunc).
|
|
|
|
:- pred apply_substitution_to_var_list(list(var(T)), map(var(T), term(T)),
|
|
list(var(T))).
|
|
:- mode apply_substitution_to_var_list(in, in, out) is det.
|
|
|
|
apply_substitution_to_var_list(Vars0, RenameSubst, Vars) :-
|
|
term__var_list_to_term_list(Vars0, Terms0),
|
|
term__apply_substitution_to_list(Terms0, RenameSubst, Terms),
|
|
term__term_list_to_var_list(Terms, Vars).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
% Make the name of the introduced pred used to check a particular
|
|
% instance of a particular class method
|
|
%
|
|
% XXX This isn't quite perfect, I suspect
|
|
:- pred make_introduced_pred_name(class_id, sym_name, arity, list(type),
|
|
sym_name).
|
|
:- mode make_introduced_pred_name(in, in, in, in, out) is det.
|
|
|
|
make_introduced_pred_name(ClassId, MethodName, Arity,
|
|
InstanceTypes, PredName) :-
|
|
ClassId = class_id(ClassName, _ClassArity),
|
|
prog_out__sym_name_to_string(ClassName, "__", ClassNameString),
|
|
prog_out__sym_name_to_string(MethodName, "__", MethodNameString),
|
|
% Perhaps we should include the arity in this mangled
|
|
% string?
|
|
string__int_to_string(Arity, ArityString),
|
|
base_typeclass_info__make_instance_string(InstanceTypes,
|
|
InstanceString),
|
|
string__append_list(
|
|
[check_typeclass__introduced_pred_name_prefix,
|
|
ClassNameString, "____",
|
|
InstanceString, "____",
|
|
MethodNameString, "_",
|
|
ArityString],
|
|
PredNameString),
|
|
PredName = unqualified(PredNameString).
|
|
|
|
% The prefix added to the class method name for the predicate
|
|
% used to call a class method for a specific instance.
|
|
:- func check_typeclass__introduced_pred_name_prefix = string.
|
|
|
|
check_typeclass__introduced_pred_name_prefix = "ClassMethod_for_".
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% check that the superclass constraints are satisfied for the
|
|
% types in this instance declaration
|
|
|
|
:- pred check_superclass_conformance(class_id, list(class_constraint),
|
|
list(tvar), tvarset, hlds_instance_defn, hlds_instance_defn,
|
|
pair(error_messages, module_info), pair(error_messages, module_info)).
|
|
:- mode check_superclass_conformance(in, in, in, in, in, out, in, out) is det.
|
|
|
|
check_superclass_conformance(ClassId, SuperClasses0, ClassVars0, ClassVarSet,
|
|
InstanceDefn0, InstanceDefn,
|
|
Errors0 - ModuleInfo, Errors - ModuleInfo) :-
|
|
|
|
InstanceDefn0 = hlds_instance_defn(A, B, Context, InstanceConstraints,
|
|
InstanceTypes, F, G, InstanceVarSet0, Proofs0),
|
|
varset__merge_subst(InstanceVarSet0, ClassVarSet, InstanceVarSet1,
|
|
Subst),
|
|
|
|
% Make the constraints in terms of the instance variables
|
|
apply_subst_to_constraint_list(Subst, SuperClasses0, SuperClasses),
|
|
|
|
% Now handle the class variables
|
|
map__apply_to_list(ClassVars0, Subst, ClassVarTerms),
|
|
(
|
|
term__var_list_to_term_list(ClassVars1, ClassVarTerms)
|
|
->
|
|
ClassVars = ClassVars1
|
|
;
|
|
error("ClassVarTerms are not vars")
|
|
),
|
|
|
|
% Calculate the bindings
|
|
map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
|
|
|
|
module_info_instances(ModuleInfo, InstanceTable),
|
|
module_info_superclasses(ModuleInfo, SuperClassTable),
|
|
|
|
% Try to reduce the superclass constraints,
|
|
% using the declared instance constraints
|
|
% and the usual context reduction rules.
|
|
typecheck__reduce_context_by_rule_application(InstanceTable,
|
|
SuperClassTable, InstanceConstraints, TypeSubst,
|
|
InstanceVarSet1, InstanceVarSet2, Proofs0, Proofs1,
|
|
SuperClasses, UnprovenConstraints),
|
|
|
|
(
|
|
UnprovenConstraints = []
|
|
->
|
|
Errors = Errors0,
|
|
InstanceDefn = hlds_instance_defn(A, B, Context,
|
|
InstanceConstraints, InstanceTypes, F, G,
|
|
InstanceVarSet2, Proofs1)
|
|
;
|
|
ClassId = class_id(ClassName, _ClassArity),
|
|
prog_out__sym_name_to_string(ClassName, ClassNameString),
|
|
InstanceTypesString = mercury_type_list_to_string(
|
|
InstanceVarSet2, InstanceTypes),
|
|
constraint_list_to_string(ClassVarSet, UnprovenConstraints,
|
|
ConstraintsString),
|
|
string__append_list([
|
|
"In instance declaration for `",
|
|
ClassNameString, "(", InstanceTypesString, ")': ",
|
|
"superclass constraint(s) not satisfied: ",
|
|
ConstraintsString, "."],
|
|
NewError),
|
|
Errors = [Context - [words(NewError)] | Errors0],
|
|
InstanceDefn = InstanceDefn0
|
|
).
|
|
|
|
:- pred constraint_list_to_string(tvarset, list(class_constraint), string).
|
|
:- mode constraint_list_to_string(in, in, out) is det.
|
|
|
|
constraint_list_to_string(_, [], "").
|
|
constraint_list_to_string(VarSet, [C|Cs], String) :-
|
|
String0 = mercury_constraint_to_string(VarSet, C),
|
|
constraint_list_to_string_2(VarSet, Cs, String1),
|
|
string__append_list(["`", String0, "'", String1], String).
|
|
|
|
:- pred constraint_list_to_string_2(tvarset, list(class_constraint), string).
|
|
:- mode constraint_list_to_string_2(in, in, out) is det.
|
|
|
|
constraint_list_to_string_2(_VarSet, [], "").
|
|
constraint_list_to_string_2(VarSet, [C|Cs], String) :-
|
|
String0 = mercury_constraint_to_string(VarSet, C),
|
|
constraint_list_to_string_2(VarSet, Cs, String1),
|
|
string__append_list([", `", String0, "'", String1], String).
|
|
|
|
%---------------------------------------------------------------------------%
|