mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-11 20:03:28 +00:00
37c2856234
Estimated hours taken: 5 Branches: main compiler/pred_table.m: The predicates that searched the pred table used to return lists of matching pred_ids, but they never returned empty lists; if there were no matching pred_ids, they failed. This diff changes them from semidet to det, and makes them return empty lists if there are no matches. This change simplifies both the code of these predicates, and the code of the predicates calling them. - Some callers of these predicates were prepared BOTH for the call to fail, and for it to succeed returning an empty list; their types allowed both. - Some pattern-matched the return value againt a one-element list in the call itself, and treated both no matches and multiple matches the same, even though an error message for one will be misleading for the other. - All calls had to have a test for cons to pick up the first match; this test was logically redundant, since they also had a test for success/failure. Change the names of the affected predicates by replacing "search" in their names with "lookup", both to give the right intuition about what they do, and to make sure I didn't miss updating any callers. compiler/add_class.m: compiler/add_clause.m: compiler/add_pragma.m: compiler/add_pred.m: compiler/check_typeclass.m: compiler/dead_proc_elim.m: compiler/deep_profiling.m: compiler/elds_to_erlang.m: compiler/hlds_module.m: compiler/intermod.m: compiler/make_hlds_passes.m: compiler/mmc_analysis.m: compiler/post_typecheck.m: compiler/recompilation.usage.m: compiler/simplify.m: compiler/type_constraints.m: compiler/typecheck.m: compiler/typecheck_errors.m: Conform to the above change.
732 lines
30 KiB
Mathematica
732 lines
30 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1993-2012 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.
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module hlds.make_hlds.add_class.
|
|
:- interface.
|
|
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module hlds.make_hlds.make_hlds_passes.
|
|
:- import_module hlds.make_hlds.qual_info.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module parse_tree.error_util.
|
|
:- import_module parse_tree.prog_data.
|
|
|
|
:- import_module list.
|
|
:- import_module term.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred module_add_class_defn(item_typeclass_info::in,
|
|
item_status::in, module_info::in, module_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
:- pred module_add_instance_defn(module_name::in, list(prog_constraint)::in,
|
|
sym_name::in, list(mer_type)::in, list(mer_type)::in, instance_body::in,
|
|
tvarset::in, import_status::in, prog_context::in,
|
|
module_info::in, module_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
% Given the definition for a predicate or function from a
|
|
% type class instance declaration, produce the clauses_info
|
|
% for that definition.
|
|
%
|
|
:- pred do_produce_instance_method_clauses(instance_proc_def::in,
|
|
pred_or_func::in, arity::in, list(mer_type)::in,
|
|
pred_markers::in, term.context::in, import_status::in, clauses_info::out,
|
|
tvarset::in, tvarset::out, module_info::in, module_info::out,
|
|
qual_info::in, qual_info::out, list(error_spec)::in, list(error_spec)::out)
|
|
is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module check_hlds.clause_to_proc.
|
|
:- import_module hlds.hlds_args.
|
|
:- import_module hlds.hlds_data.
|
|
:- import_module hlds.hlds_goal.
|
|
:- import_module hlds.hlds_rtti.
|
|
:- import_module hlds.make_hlds.add_clause.
|
|
:- import_module hlds.make_hlds.add_pred.
|
|
:- import_module hlds.make_hlds.add_type.
|
|
:- import_module hlds.make_hlds.make_hlds_error.
|
|
:- import_module hlds.make_hlds.make_hlds_warn.
|
|
:- import_module hlds.make_hlds.state_var.
|
|
:- import_module hlds.pred_table.
|
|
:- import_module parse_tree.prog_type.
|
|
:- import_module parse_tree.prog_type_subst.
|
|
:- import_module parse_tree.prog_util.
|
|
:- import_module parse_tree.set_of_var.
|
|
|
|
:- import_module bool.
|
|
:- import_module int.
|
|
:- import_module map.
|
|
:- import_module pair.
|
|
:- import_module require.
|
|
:- import_module set.
|
|
:- import_module solutions.
|
|
:- import_module string.
|
|
:- import_module varset.
|
|
|
|
module_add_class_defn(ItemTypeClassInfo, Status, !ModuleInfo, !Specs) :-
|
|
ItemTypeClassInfo = item_typeclass_info(Constraints, FunDeps, Name, Vars,
|
|
Interface, VarSet, Context, _SeqNum),
|
|
module_info_get_class_table(!.ModuleInfo, Classes0),
|
|
list.length(Vars, ClassArity),
|
|
ClassId = class_id(Name, ClassArity),
|
|
Status = item_status(ImportStatus0, _),
|
|
(
|
|
Interface = class_interface_abstract,
|
|
make_status_abstract(ImportStatus0, ImportStatus1)
|
|
;
|
|
Interface = class_interface_concrete(_),
|
|
ImportStatus1 = ImportStatus0
|
|
),
|
|
HLDSFunDeps = list.map(make_hlds_fundep(Vars), FunDeps),
|
|
(
|
|
% The typeclass is exported if *any* occurrence is exported,
|
|
% even a previous abstract occurrence.
|
|
map.search(Classes0, ClassId, OldDefn)
|
|
->
|
|
OldDefn = hlds_class_defn(OldStatus, OldConstraints, OldFunDeps,
|
|
_OldAncestors, OldVars, _OldKinds, OldInterface, OldMethods,
|
|
OldVarSet, OldContext),
|
|
combine_status(ImportStatus1, OldStatus, ImportStatus),
|
|
(
|
|
OldInterface = class_interface_concrete(_),
|
|
ClassMethods0 = OldMethods,
|
|
ClassInterface = OldInterface
|
|
;
|
|
OldInterface = class_interface_abstract,
|
|
ClassMethods0 = [],
|
|
ClassInterface = Interface
|
|
),
|
|
(
|
|
% Check that the superclass constraints are identical
|
|
\+ constraints_are_identical(OldVars, OldVarSet,
|
|
OldConstraints, Vars, VarSet, Constraints)
|
|
->
|
|
% Always report the error, even in `.opt' files.
|
|
DummyStatus = status_local,
|
|
Extras = [words("The superclass constraints do not match."), nl],
|
|
multiple_def_error(DummyStatus, Name, ClassArity, "typeclass",
|
|
Context, OldContext, Extras, !Specs),
|
|
ErrorOrPrevDef = yes
|
|
;
|
|
\+ class_fundeps_are_identical(OldFunDeps, HLDSFunDeps)
|
|
->
|
|
% Always report the error, even in `.opt' files.
|
|
DummyStatus = status_local,
|
|
Extras = [words("The functional dependencies do not match."), nl],
|
|
multiple_def_error(DummyStatus, Name, ClassArity, "typeclass",
|
|
Context, OldContext, Extras, !Specs),
|
|
ErrorOrPrevDef = yes
|
|
;
|
|
Interface = class_interface_concrete(_),
|
|
OldInterface = class_interface_concrete(_)
|
|
->
|
|
multiple_def_error(ImportStatus, Name, ClassArity,
|
|
"typeclass", Context, OldContext, [], !Specs),
|
|
ErrorOrPrevDef = yes
|
|
;
|
|
ErrorOrPrevDef = no
|
|
),
|
|
|
|
IsNewDefn = no
|
|
;
|
|
IsNewDefn = yes `with_type` bool,
|
|
ErrorOrPrevDef = no `with_type` bool,
|
|
ClassMethods0 = [],
|
|
ClassInterface = Interface,
|
|
ImportStatus = ImportStatus1
|
|
),
|
|
(
|
|
ErrorOrPrevDef = no,
|
|
(
|
|
Interface = class_interface_concrete(Methods),
|
|
module_add_class_interface(Name, Vars, Methods,
|
|
Status, PredProcIds0, !ModuleInfo, !Specs),
|
|
% Get rid of the `no's from the list of maybes
|
|
IsYes = (pred(Maybe::in, PredProcId::out) is semidet :-
|
|
Maybe = yes(Pred - Proc),
|
|
PredProcId = hlds_class_proc(Pred, Proc)
|
|
),
|
|
list.filter_map(IsYes, PredProcIds0, PredProcIds1),
|
|
|
|
% The list must be sorted on pred_id and then proc_id --
|
|
% check_typeclass.m assumes this when it is generating the
|
|
% corresponding list of pred_proc_ids for instance definitions.
|
|
list.sort(PredProcIds1, ClassMethods)
|
|
;
|
|
Interface = class_interface_abstract,
|
|
ClassMethods = ClassMethods0
|
|
),
|
|
|
|
% Ancestors is not set until check_typeclass.
|
|
Ancestors = [],
|
|
% XXX kind inference:
|
|
% We set all the kinds to `star' at the moment. This should be
|
|
% done differently when we have a proper kind system.
|
|
Kinds = map.init,
|
|
Defn = hlds_class_defn(ImportStatus, Constraints, HLDSFunDeps,
|
|
Ancestors, Vars, Kinds, ClassInterface, ClassMethods, VarSet,
|
|
Context),
|
|
map.set(ClassId, Defn, Classes0, Classes),
|
|
module_info_set_class_table(Classes, !ModuleInfo),
|
|
|
|
(
|
|
IsNewDefn = yes,
|
|
% When we find the class declaration, make an entry
|
|
% for the instances.
|
|
module_info_get_instance_table(!.ModuleInfo, Instances0),
|
|
map.det_insert(ClassId, [], Instances0, Instances),
|
|
module_info_set_instance_table(Instances, !ModuleInfo)
|
|
;
|
|
IsNewDefn = no
|
|
)
|
|
;
|
|
ErrorOrPrevDef = yes
|
|
).
|
|
|
|
:- func make_hlds_fundep(list(tvar), prog_fundep) = hlds_class_fundep.
|
|
|
|
make_hlds_fundep(TVars, fundep(Domain0, Range0)) = fundep(Domain, Range) :-
|
|
Domain = make_hlds_fundep_2(TVars, Domain0),
|
|
Range = make_hlds_fundep_2(TVars, Range0).
|
|
|
|
:- func make_hlds_fundep_2(list(tvar), list(tvar)) = set(hlds_class_argpos).
|
|
|
|
make_hlds_fundep_2(TVars, List) = list.foldl(Func, List, set.init) :-
|
|
Func = (func(TVar, Set0) = set.insert(Set0, N) :-
|
|
N = get_list_index(TVars, 1, TVar)
|
|
).
|
|
|
|
:- func get_list_index(list(T), hlds_class_argpos, T) = hlds_class_argpos.
|
|
|
|
get_list_index([], _, _) = _ :-
|
|
unexpected($module, $pred, "element not found").
|
|
get_list_index([E | Es], N, X) =
|
|
( X = E ->
|
|
N
|
|
;
|
|
get_list_index(Es, N + 1, X)
|
|
).
|
|
|
|
:- pred constraints_are_identical(list(tvar)::in, tvarset::in,
|
|
list(prog_constraint)::in, list(tvar)::in, tvarset::in,
|
|
list(prog_constraint)::in) is semidet.
|
|
|
|
constraints_are_identical(OldVars0, OldVarSet, OldConstraints0,
|
|
Vars, VarSet, Constraints) :-
|
|
tvarset_merge_renaming(VarSet, OldVarSet, _, Renaming),
|
|
apply_variable_renaming_to_prog_constraint_list(Renaming, OldConstraints0,
|
|
OldConstraints1),
|
|
apply_variable_renaming_to_tvar_list(Renaming, OldVars0, OldVars),
|
|
|
|
map.from_corresponding_lists(OldVars, Vars, VarRenaming),
|
|
apply_variable_renaming_to_prog_constraint_list(VarRenaming,
|
|
OldConstraints1, OldConstraints),
|
|
OldConstraints = Constraints.
|
|
|
|
:- pred class_fundeps_are_identical(hlds_class_fundeps::in,
|
|
hlds_class_fundeps::in) is semidet.
|
|
|
|
class_fundeps_are_identical(OldFunDeps0, FunDeps0) :-
|
|
% Allow for the functional dependencies to be in a different order.
|
|
% we rely on the fact that sets (ordered lists) have a canonical
|
|
% representation.
|
|
sort_and_remove_dups(OldFunDeps0, OldFunDeps),
|
|
sort_and_remove_dups(FunDeps0, FunDeps),
|
|
OldFunDeps = FunDeps.
|
|
|
|
:- pred module_add_class_interface(sym_name::in, list(tvar)::in,
|
|
class_methods::in, item_status::in,
|
|
list(maybe(pair(pred_id, proc_id)))::out,
|
|
module_info::in, module_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
module_add_class_interface(Name, Vars, Methods, Status, PredProcIds,
|
|
!ModuleInfo, !Specs) :-
|
|
list.filter(is_class_method_mode_item, Methods, ModeMethods,
|
|
PredOrFuncMethods),
|
|
some [!PPIds] (
|
|
add_class_pred_or_func_methods(Name, Vars, PredOrFuncMethods, Status,
|
|
!:PPIds, !ModuleInfo, !Specs),
|
|
|
|
% Add the pred_or_func_mode decls. Since we have already added the
|
|
% predicate/function method decls there should already be an entry in
|
|
% the predicate table corresponding to the mode item we are about to
|
|
% add. If not, report an error.
|
|
list.foldl3(add_class_pred_or_func_mode_method(Name, Vars, Status),
|
|
ModeMethods, !PPIds, !ModuleInfo, !Specs),
|
|
check_method_modes(Methods, !.PPIds, PredProcIds, !ModuleInfo, !Specs)
|
|
).
|
|
|
|
:- pred is_class_method_mode_item(class_method::in) is semidet.
|
|
|
|
is_class_method_mode_item(Method) :-
|
|
Method = method_pred_or_func_mode(_, _, _, _, _, _, _, _).
|
|
|
|
:- pred add_class_pred_or_func_mode_method(sym_name::in,
|
|
list(tvar)::in, item_status::in, class_method::in,
|
|
list(maybe(pair(pred_id, proc_id)))::in,
|
|
list(maybe(pair(pred_id, proc_id)))::out,
|
|
module_info::in, module_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
add_class_pred_or_func_mode_method(Name, Vars, Status, Method,
|
|
!PredProcIds, !ModuleInfo, !Specs) :-
|
|
(
|
|
Method = method_pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _, _),
|
|
unexpected($module, $pred, "pred_or_func method item")
|
|
;
|
|
Method = method_pred_or_func_mode(_VarSet, MaybePredOrFunc, PredName,
|
|
Modes, _WithInst, _MaybeDet, _Cond, Context)
|
|
),
|
|
module_info_get_predicate_table(!.ModuleInfo, PredTable),
|
|
PredArity = list.length(Modes) : int,
|
|
(
|
|
MaybePredOrFunc = no,
|
|
% The only way this could have happened now is if a `with_inst`
|
|
% annotation was not expanded.
|
|
unexpected($module, $pred, "unexpanded `with_inst` annotation")
|
|
;
|
|
MaybePredOrFunc = yes(PredOrFunc)
|
|
),
|
|
predicate_table_lookup_pf_sym_arity(PredTable, is_fully_qualified,
|
|
PredOrFunc, PredName, PredArity, PredIds),
|
|
(
|
|
PredIds = [],
|
|
missing_pred_or_func_method_error(PredName, PredArity, PredOrFunc,
|
|
Context, !Specs)
|
|
;
|
|
PredIds = [HeadPredId | TailPredIds],
|
|
(
|
|
TailPredIds = [],
|
|
PredId = HeadPredId,
|
|
module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
|
|
pred_info_get_markers(PredInfo, PredMarkers),
|
|
( check_marker(PredMarkers, marker_class_method) ->
|
|
module_add_class_method(Method, Name, Vars, Status,
|
|
PredProcId, !ModuleInfo, !Specs),
|
|
list.cons(PredProcId, !PredProcIds)
|
|
;
|
|
% XXX It may also be worth reporting that although there
|
|
% wasn't a matching class method, there was a matching
|
|
% predicate/function.
|
|
missing_pred_or_func_method_error(PredName, PredArity,
|
|
PredOrFunc, Context, !Specs)
|
|
)
|
|
;
|
|
TailPredIds = [_ | _],
|
|
% This shouldn't happen.
|
|
unexpected($module, $pred, "multiple preds matching method mode")
|
|
)
|
|
).
|
|
|
|
:- pred add_class_pred_or_func_methods(sym_name::in, list(tvar)::in,
|
|
class_methods::in, item_status::in,
|
|
list(maybe(pair(pred_id, proc_id)))::out,
|
|
module_info::in, module_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
add_class_pred_or_func_methods(_, _, [], _, [], !ModuleInfo, !Specs).
|
|
add_class_pred_or_func_methods(Name, Vars, [M | Ms], Status, [P | Ps],
|
|
!ModuleInfo, !Specs) :-
|
|
module_add_class_method(M, Name, Vars, Status, P, !ModuleInfo, !Specs),
|
|
add_class_pred_or_func_methods(Name, Vars, Ms, Status, Ps, !ModuleInfo,
|
|
!Specs).
|
|
|
|
:- pred module_add_class_method(class_method::in, sym_name::in, list(tvar)::in,
|
|
item_status::in, maybe(pair(pred_id, proc_id))::out,
|
|
module_info::in, module_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
module_add_class_method(Method, Name, Vars, Status, MaybePredIdProcId,
|
|
!ModuleInfo, !Specs) :-
|
|
(
|
|
Method = method_pred_or_func(TypeVarSet, InstVarSet, ExistQVars,
|
|
PredOrFunc, PredName, TypesAndModes, _WithType, _WithInst,
|
|
MaybeDet, _Cond, Purity, ClassContext, Context),
|
|
% XXX kind inference:
|
|
% We set the kinds to `star' at the moment. This will be different
|
|
% when we have a kind system.
|
|
prog_type.var_list_to_type_list(map.init, Vars, Args),
|
|
ClassContext = constraints(UnivCnstrs, ExistCnstrs),
|
|
NewUnivCnstrs = [constraint(Name, Args) | UnivCnstrs],
|
|
NewClassContext = constraints(NewUnivCnstrs, ExistCnstrs),
|
|
init_markers(Markers0),
|
|
add_marker(marker_class_method, Markers0, Markers),
|
|
module_add_pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
|
|
PredName, TypesAndModes, MaybeDet, Purity, NewClassContext,
|
|
Markers, Context, Status, MaybePredIdProcId, !ModuleInfo, !Specs)
|
|
;
|
|
Method = method_pred_or_func_mode(VarSet, MaybePredOrFunc, PredName,
|
|
Modes, _WithInst, MaybeDet, _Cond, Context),
|
|
(
|
|
MaybePredOrFunc = yes(PredOrFunc),
|
|
Status = item_status(ImportStatus, _),
|
|
IsClassMethod = yes,
|
|
module_add_mode(VarSet, PredName, Modes, MaybeDet, ImportStatus,
|
|
Context, PredOrFunc, IsClassMethod, PredIdProcId, !ModuleInfo,
|
|
!Specs),
|
|
MaybePredIdProcId = yes(PredIdProcId)
|
|
;
|
|
MaybePredOrFunc = no,
|
|
% equiv_type.m should have either set the
|
|
% pred_or_func or removed the item from the list.
|
|
unexpected($module, $pred, "no pred_or_func on mode declaration")
|
|
)
|
|
).
|
|
|
|
% Go through the list of class methods, looking for
|
|
% - functions without mode declarations: add a default mode
|
|
% - predicates without mode declarations: report an error
|
|
% - mode declarations with no determinism: report an error
|
|
%
|
|
:- pred check_method_modes(class_methods::in,
|
|
list(maybe(pair(pred_id, proc_id)))::in,
|
|
list(maybe(pair(pred_id, proc_id)))::out,
|
|
module_info::in, module_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
check_method_modes([], !PredProcIds, !ModuleInfo, !Specs).
|
|
check_method_modes([Method | Methods], !PredProcIds, !ModuleInfo, !Specs) :-
|
|
(
|
|
Method = method_pred_or_func(_, _, _, PorF, QualName, TypesAndModes,
|
|
_WithType, _WithInst, _, _, _, _, _),
|
|
(
|
|
QualName = qualified(ModuleName0, Name0),
|
|
ModuleName = ModuleName0,
|
|
Name = Name0
|
|
;
|
|
QualName = unqualified(_),
|
|
% The class interface should be fully module qualified
|
|
% by prog_io.m at the time it is read in.
|
|
unexpected($module, $pred, "unqualified func")
|
|
),
|
|
list.length(TypesAndModes, PredArity),
|
|
module_info_get_predicate_table(!.ModuleInfo, PredTable),
|
|
predicate_table_lookup_pf_m_n_a(PredTable, is_fully_qualified,
|
|
PorF, ModuleName, Name, PredArity, PredIds),
|
|
( PredIds = [PredId] ->
|
|
module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
|
|
(
|
|
PorF = pf_function,
|
|
maybe_add_default_func_mode(PredInfo0, PredInfo, MaybeProc),
|
|
(
|
|
MaybeProc = no
|
|
;
|
|
MaybeProc = yes(ProcId),
|
|
NewPredProc = yes(PredId - ProcId),
|
|
!:PredProcIds = [NewPredProc | !.PredProcIds],
|
|
module_info_set_pred_info(PredId, PredInfo, !ModuleInfo)
|
|
)
|
|
;
|
|
PorF = pf_predicate,
|
|
pred_info_get_procedures(PredInfo0, Procs),
|
|
( map.is_empty(Procs) ->
|
|
pred_method_with_no_modes_error(PredInfo0, !Specs)
|
|
;
|
|
true
|
|
)
|
|
)
|
|
;
|
|
unexpected($module, $pred, "number of preds != 1")
|
|
)
|
|
;
|
|
Method = method_pred_or_func_mode(_, _, _, _, _, _, _, _)
|
|
),
|
|
check_method_modes(Methods, !PredProcIds, !ModuleInfo, !Specs).
|
|
|
|
module_add_instance_defn(InstanceModuleName, Constraints, ClassName,
|
|
Types, OriginalTypes, Body0, VarSet, Status, Context,
|
|
!ModuleInfo, !Specs) :-
|
|
module_info_get_class_table(!.ModuleInfo, Classes),
|
|
module_info_get_instance_table(!.ModuleInfo, Instances0),
|
|
list.length(Types, ClassArity),
|
|
ClassId = class_id(ClassName, ClassArity),
|
|
expand_bang_states_instance_body(Body0, Body),
|
|
( map.search(Classes, ClassId, _) ->
|
|
map.init(Empty),
|
|
NewInstanceDefn = hlds_instance_defn(InstanceModuleName, Status,
|
|
Context, Constraints, Types, OriginalTypes, Body, no,
|
|
VarSet, Empty),
|
|
map.lookup(Instances0, ClassId, InstanceDefns),
|
|
|
|
check_for_overlapping_instances(NewInstanceDefn, InstanceDefns,
|
|
ClassId, !Specs),
|
|
check_instance_compatibility(NewInstanceDefn, InstanceDefns,
|
|
ClassId, !Specs),
|
|
|
|
map.det_update(ClassId, [NewInstanceDefn | InstanceDefns],
|
|
Instances0, Instances),
|
|
module_info_set_instance_table(Instances, !ModuleInfo)
|
|
;
|
|
undefined_type_class_error(ClassName, ClassArity, Context,
|
|
"instance declaration", !Specs)
|
|
).
|
|
|
|
:- pred check_for_overlapping_instances(hlds_instance_defn::in,
|
|
list(hlds_instance_defn)::in, class_id::in,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
check_for_overlapping_instances(NewInstanceDefn, InstanceDefns, ClassId,
|
|
!Specs) :-
|
|
IsOverlapping = (pred((Context - OtherContext)::out) is nondet :-
|
|
NewInstanceDefn = hlds_instance_defn(_, _Status, Context,
|
|
_, Types, _, Body, _, VarSet, _),
|
|
Body = instance_body_concrete(_), % XXX
|
|
list.member(OtherInstanceDefn, InstanceDefns),
|
|
OtherInstanceDefn = hlds_instance_defn(_, _OtherStatus,
|
|
OtherContext, _, OtherTypes, _, OtherBody, _, OtherVarSet, _),
|
|
OtherBody = instance_body_concrete(_), % XXX
|
|
tvarset_merge_renaming(VarSet, OtherVarSet, _NewVarSet, Renaming),
|
|
apply_variable_renaming_to_type_list(Renaming, OtherTypes,
|
|
NewOtherTypes),
|
|
type_list_subsumes(Types, NewOtherTypes, _)
|
|
),
|
|
solutions.aggregate(IsOverlapping,
|
|
report_overlapping_instance_declaration(ClassId), !Specs).
|
|
|
|
:- pred report_overlapping_instance_declaration(class_id::in,
|
|
pair(prog_context)::in,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
report_overlapping_instance_declaration(class_id(ClassName, ClassArity),
|
|
Context - OtherContext, !Specs) :-
|
|
Pieces1 = [words("Error: multiply defined (or overlapping)"),
|
|
words("instance declarations for class"),
|
|
sym_name_and_arity(ClassName / ClassArity),
|
|
suffix("."), nl],
|
|
Pieces2 = [words("Previous instance declaration was here.")],
|
|
Msg1 = simple_msg(Context, [always(Pieces1)]),
|
|
Msg2 = error_msg(yes(OtherContext), treat_as_first, 0, [always(Pieces2)]),
|
|
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg1, Msg2]),
|
|
!:Specs = [Spec | !.Specs].
|
|
|
|
|
|
%
|
|
% If two instance declarations are about the same type, then
|
|
% the declarations must be compatible. This consists of checking
|
|
% that the constraints are identical.
|
|
% In other words, the abstract declaration must match the
|
|
% concrete definition.
|
|
%
|
|
:- pred check_instance_compatibility(hlds_instance_defn::in,
|
|
list(hlds_instance_defn)::in, class_id::in,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
check_instance_compatibility(InstanceDefn, InstanceDefns, ClassId, !Specs) :-
|
|
list.filter(same_type_hlds_instance_defn(InstanceDefn),
|
|
InstanceDefns, EquivInstanceDefns),
|
|
list.foldl(check_instance_constraints(InstanceDefn, ClassId),
|
|
EquivInstanceDefns, !Specs).
|
|
|
|
:- pred check_instance_constraints(hlds_instance_defn::in,
|
|
class_id::in, hlds_instance_defn::in,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
check_instance_constraints(InstanceDefnA, ClassId, InstanceDefnB, !Specs) :-
|
|
type_vars_list(InstanceDefnA ^ instance_types, TVarsA),
|
|
TVarsetA = InstanceDefnA ^ instance_tvarset,
|
|
ConstraintsA = InstanceDefnA ^ instance_constraints,
|
|
|
|
type_vars_list(InstanceDefnB ^ instance_types, TVarsB),
|
|
TVarsetB = InstanceDefnB ^ instance_tvarset,
|
|
ConstraintsB = InstanceDefnB ^ instance_constraints,
|
|
|
|
(
|
|
constraints_are_identical(TVarsA, TVarsetA, ConstraintsA,
|
|
TVarsB, TVarsetB, ConstraintsB)
|
|
->
|
|
true
|
|
;
|
|
ClassId = class_id(Name, ClassArity),
|
|
ContextA = InstanceDefnA ^ instance_context,
|
|
|
|
TxtA = [words("In instance declaration for class "),
|
|
sym_name_and_arity(Name / ClassArity), nl,
|
|
words("instance constraints are incompatible with")],
|
|
MsgA = simple_msg(ContextA, [always(TxtA)]),
|
|
|
|
ContextB = InstanceDefnB ^ instance_context,
|
|
TxtB = [words("instance constraints here.")],
|
|
MsgB = simple_msg(ContextB, [always(TxtB)]),
|
|
|
|
Spec = error_spec(severity_error,
|
|
phase_parse_tree_to_hlds, [MsgA, MsgB]),
|
|
!:Specs = [Spec | !.Specs]
|
|
).
|
|
|
|
% Do two hlds_instance_defn refer to the same type?
|
|
% eg "instance tc(f(T))" compares equal to "instance tc(f(U))"
|
|
%
|
|
% Note we don't check that the constraints of the declarations are the
|
|
% same.
|
|
%
|
|
:- pred same_type_hlds_instance_defn(hlds_instance_defn::in,
|
|
hlds_instance_defn::in) is semidet.
|
|
|
|
same_type_hlds_instance_defn(InstanceDefnA, InstanceDefnB) :-
|
|
TypesA = InstanceDefnA ^ instance_types,
|
|
TypesB0 = InstanceDefnB ^ instance_types,
|
|
|
|
VarSetA = InstanceDefnA ^ instance_tvarset,
|
|
VarSetB = InstanceDefnB ^ instance_tvarset,
|
|
|
|
% Rename the two lists of types apart.
|
|
tvarset_merge_renaming(VarSetA, VarSetB, _NewVarSet, RenameApart),
|
|
apply_variable_renaming_to_type_list(RenameApart, TypesB0, TypesB1),
|
|
|
|
type_vars_list(TypesA, TVarsA),
|
|
type_vars_list(TypesB1, TVarsB),
|
|
|
|
% If the lengths are different they can't be the same type.
|
|
list.length(TVarsA, L),
|
|
list.length(TVarsB, L),
|
|
|
|
map.from_corresponding_lists(TVarsB, TVarsA, Renaming),
|
|
apply_variable_renaming_to_type_list(Renaming, TypesB1, TypesB),
|
|
|
|
TypesA = TypesB.
|
|
|
|
do_produce_instance_method_clauses(InstanceProcDefn, PredOrFunc, PredArity,
|
|
ArgTypes, Markers, Context, Status, ClausesInfo, !TVarSet, !ModuleInfo,
|
|
!QualInfo, !Specs) :-
|
|
(
|
|
% Handle the `pred(<MethodName>/<Arity>) is <ImplName>' syntax.
|
|
InstanceProcDefn = instance_proc_def_name(InstancePredName),
|
|
% Add the body of the introduced pred.
|
|
% First the goal info, ...
|
|
goal_info_init(GoalInfo0),
|
|
goal_info_set_context(Context, GoalInfo0, GoalInfo1),
|
|
set_of_var.list_to_set(HeadVars, NonLocals),
|
|
goal_info_set_nonlocals(NonLocals, GoalInfo1, GoalInfo2),
|
|
( check_marker(Markers, marker_is_impure) ->
|
|
goal_info_set_purity(purity_impure, GoalInfo2, GoalInfo)
|
|
; check_marker(Markers, marker_is_semipure) ->
|
|
goal_info_set_purity(purity_semipure, GoalInfo2, GoalInfo)
|
|
;
|
|
GoalInfo = GoalInfo2
|
|
),
|
|
% ... and then the goal itself.
|
|
varset.init(VarSet0),
|
|
make_n_fresh_vars("HeadVar__", PredArity, HeadVars, VarSet0, VarSet),
|
|
construct_pred_or_func_call(invalid_pred_id, PredOrFunc,
|
|
InstancePredName, HeadVars, GoalInfo, IntroducedGoal, !QualInfo),
|
|
IntroducedClause = clause(all_modes, IntroducedGoal, impl_lang_mercury,
|
|
Context, []),
|
|
|
|
map.init(TVarNameMap),
|
|
vartypes_from_corresponding_lists(HeadVars, ArgTypes, VarTypes),
|
|
HeadVarVec = proc_arg_vector_init(PredOrFunc, HeadVars),
|
|
set_clause_list([IntroducedClause], ClausesRep),
|
|
rtti_varmaps_init(RttiVarMaps),
|
|
HasForeignClauses = no,
|
|
ClausesInfo = clauses_info(VarSet, VarTypes, TVarNameMap, VarTypes,
|
|
HeadVarVec, ClausesRep, init_clause_item_numbers_comp_gen,
|
|
RttiVarMaps, HasForeignClauses)
|
|
;
|
|
% Handle the arbitrary clauses syntax.
|
|
InstanceProcDefn = instance_proc_def_clauses(InstanceClauses),
|
|
clauses_info_init(PredOrFunc, PredArity,
|
|
init_clause_item_numbers_comp_gen, ClausesInfo0),
|
|
list.foldl5(
|
|
produce_instance_method_clause(PredOrFunc, Context, Status),
|
|
InstanceClauses, !TVarSet, !ModuleInfo, !QualInfo,
|
|
ClausesInfo0, ClausesInfo, !Specs)
|
|
).
|
|
|
|
:- pred produce_instance_method_clause(pred_or_func::in,
|
|
prog_context::in, import_status::in, item_clause_info::in,
|
|
tvarset::in, tvarset::out, module_info::in, module_info::out,
|
|
qual_info::in, qual_info::out, clauses_info::in, clauses_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
produce_instance_method_clause(PredOrFunc, Context, Status, InstanceClause,
|
|
TVarSet0, TVarSet, !ModuleInfo, !QualInfo, !ClausesInfo, !Specs) :-
|
|
InstanceClause = item_clause_info(_Origin, CVarSet, ClausePredOrFunc,
|
|
PredName, HeadTerms0, Body, _ClauseContext, _SeqNum),
|
|
% XXX Can this ever fail? If yes, we should generate an error message
|
|
% instead of aborting.
|
|
expect(unify(PredOrFunc, ClausePredOrFunc), $module, $pred,
|
|
"PredOrFunc mismatch"),
|
|
( illegal_state_var_func_result(PredOrFunc, HeadTerms0, StateVar) ->
|
|
TVarSet = TVarSet0,
|
|
report_illegal_func_svar_result(Context, CVarSet, StateVar, !Specs)
|
|
;
|
|
expand_bang_states(HeadTerms0, HeadTerms),
|
|
PredArity = list.length(HeadTerms),
|
|
adjust_func_arity(PredOrFunc, Arity, PredArity),
|
|
|
|
% AllProcIds is only used when the predicate has foreign procs,
|
|
% which the instance method pred should not have, so this dummy value
|
|
% should be ok.
|
|
AllProcIds = [],
|
|
|
|
GoalType = goal_type_none, % goal is not a promise
|
|
clauses_info_add_clause(all_modes, AllProcIds, CVarSet, TVarSet0,
|
|
HeadTerms, Body, Context, no, Status, PredOrFunc, Arity,
|
|
GoalType, Goal, VarSet, TVarSet, !ClausesInfo, Warnings,
|
|
!ModuleInfo, !QualInfo, !Specs),
|
|
|
|
SimpleCallId = simple_call_id(PredOrFunc, PredName, Arity),
|
|
|
|
% Warn about singleton variables.
|
|
warn_singletons(!.ModuleInfo, SimpleCallId, VarSet, Goal, !Specs),
|
|
|
|
% Warn about variables with overlapping scopes.
|
|
warn_overlap(Warnings, VarSet, SimpleCallId, !Specs)
|
|
).
|
|
|
|
:- pred pred_method_with_no_modes_error(pred_info::in,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
pred_method_with_no_modes_error(PredInfo, !Specs) :-
|
|
pred_info_get_context(PredInfo, Context),
|
|
Module = pred_info_module(PredInfo),
|
|
Name = pred_info_name(PredInfo),
|
|
Arity = pred_info_orig_arity(PredInfo),
|
|
|
|
Pieces = [words("Error: no mode declaration"),
|
|
words("for type class method predicate"),
|
|
sym_name_and_arity(qualified(Module, Name) / Arity), suffix("."), nl],
|
|
Msg = simple_msg(Context, [always(Pieces)]),
|
|
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
|
|
!:Specs = [Spec | !.Specs].
|
|
|
|
:- pred undefined_type_class_error(sym_name::in, arity::in, prog_context::in,
|
|
string::in, list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
undefined_type_class_error(ClassName, Arity, Context, Description, !Specs) :-
|
|
Pieces = [words("Error:"), words(Description), words("for"),
|
|
sym_name_and_arity(ClassName / Arity),
|
|
words("without preceding typeclass declaration."), nl],
|
|
Msg = simple_msg(Context, [always(Pieces)]),
|
|
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
|
|
!:Specs = [Spec | !.Specs].
|
|
|
|
:- pred missing_pred_or_func_method_error(sym_name::in, arity::in,
|
|
pred_or_func::in, prog_context::in,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
missing_pred_or_func_method_error(Name, Arity, PredOrFunc, Context, !Specs) :-
|
|
Pieces = [words("Error: mode declaration for type class method"),
|
|
sym_name_and_arity(Name / Arity), words("without corresponding"),
|
|
p_or_f(PredOrFunc), words("method declaration."), nl],
|
|
Msg = simple_msg(Context, [always(Pieces)]),
|
|
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
|
|
!:Specs = [Spec | !.Specs].
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
:- end_module hlds.make_hlds.add_class.
|
|
%-----------------------------------------------------------------------------%
|