mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-18 15:26:31 +00:00
459847a064
Estimated hours taken: 18 Branches: main Move the univ, maybe, pair and unit types from std_util into their own modules. std_util still contains the general purpose higher-order programming constructs. library/std_util.m: Move univ, maybe, pair and unit (plus any other related types and procedures) into their own modules. library/maybe.m: New module. This contains the maybe and maybe_error types and the associated procedures. library/pair.m: New module. This contains the pair type and associated procedures. library/unit.m: New module. This contains the types unit/0 and unit/1. library/univ.m: New module. This contains the univ type and associated procedures. library/library.m: Add the new modules. library/private_builtin.m: Update the declaration of the type_ctor_info struct for univ. runtime/mercury.h: Update the declaration for the type_ctor_info struct for univ. runtime/mercury_mcpp.h: runtime/mercury_hlc_types.h: Update the definition of MR_Univ. runtime/mercury_init.h: Fix a comment: ML_type_name is now exported from type_desc.m. compiler/mlds_to_il.m: Update the the name of the module that defines univs (which are handled specially by the il code generator.) library/*.m: compiler/*.m: browser/*.m: mdbcomp/*.m: profiler/*.m: deep_profiler/*.m: Conform to the above changes. Import the new modules where they are needed; don't import std_util where it isn't needed. Fix formatting in lots of modules. Delete duplicate module imports. tests/*: Update the test suite to confrom to the above changes.
679 lines
27 KiB
Mathematica
679 lines
27 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1993-2006 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.prog_data.
|
|
|
|
:- import_module io.
|
|
:- import_module list.
|
|
:- import_module term.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred module_add_class_defn(list(prog_constraint)::in,
|
|
list(prog_fundep)::in, sym_name::in, list(tvar)::in, class_interface::in,
|
|
tvarset::in, prog_context::in, item_status::in,
|
|
module_info::in, module_info::out, io::di, io::uo) is det.
|
|
|
|
:- pred module_add_instance_defn(module_name::in, list(prog_constraint)::in,
|
|
sym_name::in, list(mer_type)::in, instance_body::in, tvarset::in,
|
|
import_status::in, prog_context::in,
|
|
module_info::in, module_info::out, io::di, io::uo) 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,
|
|
module_info::in, module_info::out, qual_info::in, qual_info::out,
|
|
io::di, io::uo) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module check_hlds.clause_to_proc.
|
|
:- 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 libs.compiler_util.
|
|
:- import_module parse_tree.error_util.
|
|
:- import_module parse_tree.prog_out.
|
|
:- import_module parse_tree.prog_type.
|
|
:- import_module parse_tree.prog_type_subst.
|
|
:- import_module parse_tree.prog_util.
|
|
|
|
:- import_module bool.
|
|
:- import_module int.
|
|
:- import_module map.
|
|
:- import_module multi_map.
|
|
:- import_module pair.
|
|
:- import_module set.
|
|
:- import_module solutions.
|
|
:- import_module string.
|
|
:- import_module varset.
|
|
|
|
module_add_class_defn(Constraints, FunDeps, Name, Vars, Interface, VarSet,
|
|
Context, Status, !ModuleInfo, !IO) :-
|
|
module_info_get_class_table(!.ModuleInfo, Classes0),
|
|
module_info_get_superclass_table(!.ModuleInfo, SuperClasses0),
|
|
list.length(Vars, ClassArity),
|
|
ClassId = class_id(Name, ClassArity),
|
|
Status = item_status(ImportStatus0, _),
|
|
( Interface = abstract ->
|
|
make_status_abstract(ImportStatus0, ImportStatus1)
|
|
;
|
|
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 = concrete(_),
|
|
ClassMethods0 = OldMethods,
|
|
ClassInterface = OldInterface
|
|
;
|
|
OldInterface = abstract,
|
|
ClassMethods0 = [],
|
|
ClassInterface = Interface
|
|
),
|
|
(
|
|
\+ superclass_constraints_are_identical(OldVars, OldVarSet,
|
|
OldConstraints, Vars, VarSet, Constraints)
|
|
->
|
|
% Always report the error, even in `.opt' files.
|
|
DummyStatus = local,
|
|
multiple_def_error(DummyStatus, Name, ClassArity, "typeclass",
|
|
Context, OldContext, _, !IO),
|
|
prog_out.write_context(Context, !IO),
|
|
io.write_string(" The superclass constraints do not match.\n",
|
|
!IO),
|
|
io.set_exit_status(1, !IO),
|
|
ErrorOrPrevDef = yes
|
|
;
|
|
\+ class_fundeps_are_identical(OldFunDeps, HLDSFunDeps)
|
|
->
|
|
% Always report the error, even in `.opt' files.
|
|
DummyStatus = local,
|
|
multiple_def_error(DummyStatus, Name, ClassArity, "typeclass",
|
|
Context, OldContext, _, !IO),
|
|
prog_out.write_context(Context, !IO),
|
|
io.write_string(" The functional dependencies do not match.\n",
|
|
!IO),
|
|
io.set_exit_status(1, !IO),
|
|
ErrorOrPrevDef = yes
|
|
;
|
|
Interface = concrete(_),
|
|
OldInterface = concrete(_)
|
|
->
|
|
multiple_def_error(ImportStatus, Name, ClassArity,
|
|
"typeclass", Context, OldContext, _, !IO),
|
|
ErrorOrPrevDef = yes
|
|
;
|
|
ErrorOrPrevDef = no
|
|
),
|
|
|
|
IsNewDefn = no
|
|
;
|
|
IsNewDefn = yes `with_type` bool,
|
|
ErrorOrPrevDef = no `with_type` bool,
|
|
ClassMethods0 = [],
|
|
ClassInterface = Interface,
|
|
ImportStatus = ImportStatus1
|
|
),
|
|
(
|
|
ErrorOrPrevDef = no,
|
|
(
|
|
Interface = concrete(Methods),
|
|
module_add_class_interface(Name, Vars, Methods,
|
|
Status, PredProcIds0, !ModuleInfo, !IO),
|
|
% 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 = 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(Classes0, ClassId, Defn, Classes),
|
|
module_info_set_class_table(Classes, !ModuleInfo),
|
|
|
|
(
|
|
IsNewDefn = yes,
|
|
update_superclass_table(ClassId, Vars, VarSet, Constraints,
|
|
SuperClasses0, SuperClasses),
|
|
|
|
module_info_set_superclass_table(SuperClasses, !ModuleInfo),
|
|
|
|
% When we find the class declaration, make an
|
|
% entry for the instances.
|
|
module_info_get_instance_table(!.ModuleInfo, Instances0),
|
|
map.det_insert(Instances0, ClassId, [], 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(this_file, "get_list_index: element not found").
|
|
get_list_index([E | Es], N, X) =
|
|
( X = E ->
|
|
N
|
|
;
|
|
get_list_index(Es, N + 1, X)
|
|
).
|
|
|
|
:- pred superclass_constraints_are_identical(list(tvar)::in, tvarset::in,
|
|
list(prog_constraint)::in, list(tvar)::in, tvarset::in,
|
|
list(prog_constraint)::in) is semidet.
|
|
|
|
superclass_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, io::di, io::uo) is det.
|
|
|
|
module_add_class_interface(Name, Vars, Methods, Status, PredProcIds,
|
|
!ModuleInfo, !IO) :-
|
|
list.filter(is_class_method_mode_item, Methods, ModeMethods,
|
|
PredOrFuncMethods),
|
|
some [!PPIds] (
|
|
add_class_pred_or_func_methods(Name, Vars, PredOrFuncMethods, Status,
|
|
!:PPIds, !ModuleInfo, !IO),
|
|
%
|
|
% 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, !IO),
|
|
check_method_modes(Methods, !.PPIds, PredProcIds, !ModuleInfo, !IO)
|
|
).
|
|
|
|
:- pred is_class_method_mode_item(class_method::in) is semidet.
|
|
|
|
is_class_method_mode_item(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, io::di, io::uo) is det.
|
|
|
|
add_class_pred_or_func_mode_method(Name, Vars, Status, Method,
|
|
!PredProcIds, !ModuleInfo, !IO) :-
|
|
(
|
|
Method = pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _, _),
|
|
unexpected(this_file, "add_class_pred_or_func_mode_method: " ++
|
|
"pred_or_func method item")
|
|
;
|
|
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,
|
|
(
|
|
% The only way this could have happened now is if a `with_inst`
|
|
% annotation was not expanded.
|
|
%
|
|
MaybePredOrFunc = no,
|
|
unexpected(this_file, "add_class_pred_or_func_mode_method: " ++
|
|
"unexpanded `with_inst` annotation")
|
|
;
|
|
MaybePredOrFunc = yes(PredOrFunc)
|
|
),
|
|
(
|
|
predicate_table_search_pf_sym_arity(PredTable, is_fully_qualified,
|
|
PredOrFunc, PredName, PredArity, Preds),
|
|
Preds \= []
|
|
->
|
|
(
|
|
% This case should have been caught above.
|
|
Preds = [],
|
|
unexpected(this_file, "empty list")
|
|
;
|
|
Preds = [PredId],
|
|
module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
|
|
pred_info_get_markers(PredInfo, PredMarkers),
|
|
( check_marker(PredMarkers, class_method) ->
|
|
module_add_class_method(Method, Name, Vars, Status,
|
|
PredProcId, !ModuleInfo, !IO),
|
|
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, !ModuleInfo, !IO)
|
|
)
|
|
;
|
|
% This shouldn't happen.
|
|
Preds = [_, _ | _],
|
|
unexpected(this_file, "multiple preds matching method mode")
|
|
)
|
|
;
|
|
missing_pred_or_func_method_error(PredName, PredArity,
|
|
PredOrFunc, Context, !ModuleInfo, !IO)
|
|
).
|
|
|
|
:- 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, io::di, io::uo) is det.
|
|
|
|
add_class_pred_or_func_methods(_, _, [], _, [], !ModuleInfo, !IO).
|
|
add_class_pred_or_func_methods(Name, Vars, [M | Ms], Status, [P | Ps],
|
|
!ModuleInfo, !IO) :-
|
|
module_add_class_method(M, Name, Vars, Status, P, !ModuleInfo, !IO),
|
|
add_class_pred_or_func_methods(Name, Vars, Ms, Status, Ps, !ModuleInfo,
|
|
!IO).
|
|
|
|
:- 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, io::di, io::uo) is det.
|
|
|
|
module_add_class_method(Method, Name, Vars, Status, MaybePredIdProcId,
|
|
!ModuleInfo, !IO) :-
|
|
(
|
|
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(class_method, Markers0, Markers),
|
|
module_add_pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
|
|
PredName, TypesAndModes, MaybeDet, Purity, NewClassContext,
|
|
Markers, Context, Status, MaybePredIdProcId, !ModuleInfo, !IO)
|
|
;
|
|
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,
|
|
!IO),
|
|
MaybePredIdProcId = yes(PredIdProcId)
|
|
;
|
|
MaybePredOrFunc = no,
|
|
% equiv_type.m should have either set the
|
|
% pred_or_func or removed the item from the list.
|
|
unexpected(this_file, "module_add_class_method: " ++
|
|
"no pred_or_func on mode declaration")
|
|
)
|
|
).
|
|
|
|
% Insert an entry into the super class table for each super class of
|
|
% this class.
|
|
%
|
|
:- pred update_superclass_table(class_id::in, list(tvar)::in, tvarset::in,
|
|
list(prog_constraint)::in, superclass_table::in, superclass_table::out)
|
|
is det.
|
|
|
|
update_superclass_table(ClassId, Vars, VarSet, Constraints, !Supers) :-
|
|
list.foldl(update_superclass_table_2(ClassId, Vars, VarSet), Constraints,
|
|
!Supers).
|
|
|
|
:- pred update_superclass_table_2(class_id::in, list(tvar)::in, tvarset::in,
|
|
prog_constraint::in, superclass_table::in, superclass_table::out) is det.
|
|
|
|
update_superclass_table_2(ClassId, Vars, VarSet, Constraint, !Supers) :-
|
|
Constraint = constraint(SuperName, SuperTypes),
|
|
list.length(SuperTypes, SuperClassArity),
|
|
SuperClassId = class_id(SuperName, SuperClassArity),
|
|
SubClassDetails = subclass_details(SuperTypes, ClassId, Vars, VarSet),
|
|
multi_map.set(!.Supers, SuperClassId, SubClassDetails, !:Supers).
|
|
|
|
% 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, io::di, io::uo) is det.
|
|
|
|
check_method_modes([], !PredProcIds, !ModuleInfo, !IO).
|
|
check_method_modes([Method | Methods], !PredProcIds, !ModuleInfo, !IO) :-
|
|
(
|
|
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(this_file,
|
|
"add_default_class_method_func_modes: unqualified func")
|
|
),
|
|
list.length(TypesAndModes, PredArity),
|
|
module_info_get_predicate_table(!.ModuleInfo, PredTable),
|
|
(
|
|
predicate_table_search_pf_m_n_a(PredTable, is_fully_qualified,
|
|
PorF, ModuleName, Name, PredArity, [PredId])
|
|
->
|
|
module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
|
|
(
|
|
PorF = 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 = predicate,
|
|
pred_info_get_procedures(PredInfo0, Procs),
|
|
( map.is_empty(Procs) ->
|
|
pred_method_with_no_modes_error(PredInfo0, !IO)
|
|
;
|
|
true
|
|
)
|
|
)
|
|
;
|
|
unexpected(this_file, "handle_methods_with_no_modes")
|
|
)
|
|
;
|
|
true
|
|
),
|
|
check_method_modes(Methods, !PredProcIds, !ModuleInfo, !IO).
|
|
|
|
module_add_instance_defn(InstanceModuleName, Constraints, ClassName,
|
|
Types, Body0, VarSet, Status, Context, !ModuleInfo, !IO) :-
|
|
module_info_get_class_table(!.ModuleInfo, Classes),
|
|
module_info_get_instance_table(!.ModuleInfo, Instances0),
|
|
list.length(Types, ClassArity),
|
|
ClassId = class_id(ClassName, ClassArity),
|
|
Body = expand_bang_state_var_args_in_instance_method_heads(Body0),
|
|
( map.search(Classes, ClassId, _) ->
|
|
map.init(Empty),
|
|
NewInstanceDefn = hlds_instance_defn(InstanceModuleName, Status,
|
|
Context, Constraints, Types, Body, no, VarSet, Empty),
|
|
map.lookup(Instances0, ClassId, InstanceDefns),
|
|
check_for_overlapping_instances(NewInstanceDefn, InstanceDefns,
|
|
ClassId, !IO),
|
|
map.det_update(Instances0, ClassId,
|
|
[NewInstanceDefn | InstanceDefns], Instances),
|
|
module_info_set_instance_table(Instances, !ModuleInfo)
|
|
;
|
|
undefined_type_class_error(ClassName, ClassArity, Context,
|
|
"instance declaration", !IO)
|
|
).
|
|
|
|
:- pred check_for_overlapping_instances(hlds_instance_defn::in,
|
|
list(hlds_instance_defn)::in, class_id::in, io::di, io::uo) is det.
|
|
|
|
check_for_overlapping_instances(NewInstanceDefn, InstanceDefns, ClassId,
|
|
!IO) :-
|
|
IsOverlapping = (pred((Context - OtherContext)::out) is nondet :-
|
|
NewInstanceDefn = hlds_instance_defn(_, _Status, Context,
|
|
_, Types, Body, _, VarSet, _),
|
|
Body \= abstract, % XXX
|
|
list.member(OtherInstanceDefn, InstanceDefns),
|
|
OtherInstanceDefn = hlds_instance_defn(_, _OtherStatus,
|
|
OtherContext, _, OtherTypes, OtherBody, _, OtherVarSet, _),
|
|
OtherBody \= abstract, % 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), !IO).
|
|
|
|
:- pred report_overlapping_instance_declaration(class_id::in,
|
|
pair(prog_context)::in, io::di, io::uo) is det.
|
|
|
|
report_overlapping_instance_declaration(class_id(ClassName, ClassArity),
|
|
Context - OtherContext, !IO) :-
|
|
io.set_exit_status(1, !IO),
|
|
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.")],
|
|
write_error_pieces(Context, 0, Pieces1, !IO),
|
|
write_error_pieces(OtherContext, 0, Pieces2, !IO).
|
|
|
|
do_produce_instance_method_clauses(InstanceProcDefn, PredOrFunc, PredArity,
|
|
ArgTypes, Markers, Context, Status, ClausesInfo, !ModuleInfo,
|
|
!QualInfo, !IO) :-
|
|
(
|
|
% Handle the `pred(<MethodName>/<Arity>) is <ImplName>' syntax.
|
|
InstanceProcDefn = 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.list_to_set(HeadVars, NonLocals),
|
|
goal_info_set_nonlocals(NonLocals, GoalInfo1, GoalInfo2),
|
|
( check_marker(Markers, is_impure) ->
|
|
goal_info_add_feature(impure_goal, GoalInfo2, GoalInfo)
|
|
; check_marker(Markers, is_semipure) ->
|
|
goal_info_add_feature(semipure_goal, 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([], IntroducedGoal, mercury, Context),
|
|
|
|
map.from_corresponding_lists(HeadVars, ArgTypes, VarTypes),
|
|
map.init(TVarNameMap),
|
|
rtti_varmaps_init(RttiVarMaps),
|
|
HasForeignClauses = no,
|
|
set_clause_list([IntroducedClause], ClausesRep),
|
|
ClausesInfo = clauses_info(VarSet, VarTypes, TVarNameMap, VarTypes,
|
|
HeadVars, ClausesRep, RttiVarMaps, HasForeignClauses)
|
|
;
|
|
% Handle the arbitrary clauses syntax.
|
|
InstanceProcDefn = clauses(InstanceClauses),
|
|
clauses_info_init(PredArity, ClausesInfo0),
|
|
list.foldl4(
|
|
produce_instance_method_clause(PredOrFunc, Context, Status),
|
|
InstanceClauses, !ModuleInfo, !QualInfo,
|
|
ClausesInfo0, ClausesInfo, !IO)
|
|
).
|
|
|
|
:- pred produce_instance_method_clause(pred_or_func::in,
|
|
prog_context::in, import_status::in, item::in,
|
|
module_info::in, module_info::out, qual_info::in, qual_info::out,
|
|
clauses_info::in, clauses_info::out, io::di, io::uo) is det.
|
|
|
|
produce_instance_method_clause(PredOrFunc, Context, Status, InstanceClause,
|
|
!ModuleInfo, !QualInfo, !ClausesInfo, !IO) :-
|
|
(
|
|
InstanceClause = clause(_Origin, CVarSet, PredOrFunc, PredName,
|
|
HeadTerms0, Body)
|
|
->
|
|
( illegal_state_var_func_result(PredOrFunc, HeadTerms0, StateVar) ->
|
|
report_illegal_func_svar_result(Context, CVarSet, StateVar, !IO)
|
|
;
|
|
HeadTerms = expand_bang_state_var_args(HeadTerms0),
|
|
PredArity = list.length(HeadTerms),
|
|
adjust_func_arity(PredOrFunc, Arity, PredArity),
|
|
% The tvarset argument is only used for explicit type
|
|
% qualifications, of which there are none in this
|
|
% clause, so it is set to a dummy value.
|
|
varset.init(TVarSet0),
|
|
|
|
ProcIds = [],
|
|
% means this clause applies to _every_ mode of the procedure
|
|
GoalType = none, % goal is not a promise
|
|
clauses_info_add_clause(ProcIds, CVarSet, TVarSet0, HeadTerms,
|
|
Body, Context, Status, PredOrFunc, Arity, GoalType, Goal,
|
|
VarSet, _TVarSet, !ClausesInfo, Warnings, !ModuleInfo,
|
|
!QualInfo, !IO),
|
|
|
|
% Warn about singleton variables.
|
|
maybe_warn_singletons(VarSet, PredOrFunc - PredName/Arity,
|
|
!.ModuleInfo, Goal, !IO),
|
|
|
|
% Warn about variables with overlapping scopes.
|
|
maybe_warn_overlap(Warnings, VarSet, PredOrFunc - PredName/Arity,
|
|
!IO)
|
|
)
|
|
;
|
|
unexpected(this_file, "produce_clause: invalid instance item")
|
|
).
|
|
|
|
:- pred pred_method_with_no_modes_error(pred_info::in, io::di, io::uo) is det.
|
|
|
|
pred_method_with_no_modes_error(PredInfo, !IO) :-
|
|
pred_info_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 for type class method"),
|
|
words("predicate"),
|
|
sym_name_and_arity(qualified(Module, Name) / Arity), suffix(".")],
|
|
write_error_pieces(Context, 0, Pieces, !IO),
|
|
io.set_exit_status(1, !IO).
|
|
|
|
:- pred undefined_type_class_error(sym_name::in, arity::in, prog_context::in,
|
|
string::in, io::di, io::uo) is det.
|
|
|
|
undefined_type_class_error(ClassName, Arity, Context, Description, !IO) :-
|
|
Pieces = [words("Error:"), words(Description), words("for"),
|
|
sym_name_and_arity(ClassName / Arity),
|
|
words("without preceding typeclass declaration.")],
|
|
write_error_pieces(Context, 0, Pieces, !IO),
|
|
io.set_exit_status(1, !IO).
|
|
|
|
:- pred missing_pred_or_func_method_error(sym_name::in, arity::in,
|
|
pred_or_func::in, prog_context::in, module_info::in, module_info::out,
|
|
io::di, io::uo) is det.
|
|
|
|
missing_pred_or_func_method_error(Name, Arity, PredOrFunc, Context,
|
|
!ModuleInfo, !IO) :-
|
|
NoPredOrFuncMsg = [
|
|
words("Error: mode declaration for type class method"),
|
|
sym_name_and_arity(Name / Arity),
|
|
words("without corresponding"),
|
|
pred_or_func(PredOrFunc),
|
|
words("method declaration.")
|
|
],
|
|
write_error_pieces(Context, 0, NoPredOrFuncMsg, !IO),
|
|
io.set_exit_status(1, !IO),
|
|
module_info_incr_errors(!ModuleInfo).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- func this_file = string.
|
|
|
|
this_file = "add_class.m".
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
:- end_module add_class.
|
|
%-----------------------------------------------------------------------------%
|