%-----------------------------------------------------------------------------% % 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(/) is ' 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. %-----------------------------------------------------------------------------%