mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-18 07:15:19 +00:00
Code Issues Projects Releases Wiki Activity
Files
cdf9ccf352049af16824810a403be67a69f11c0b
mercury/compiler/add_class.m
Mark Brown 3fc6b3f128 Change the representation of types in the compiler. 
Estimated hours taken: 30
Branches: main

Change the representation of types in the compiler.

We also add some support for handling kinds, which will be used later when we
have a kind system.  There are a number of places where kinds are not yet
handled correctly -- we assume that all kinds will be `star'.  Each of these
locations is flagged with a comment that contains "XXX kind inference:".


compiler/prog_data.m:
	Implement the new version of type (type).

	Change the definition of type_param to be a variable instead of a
	term, since all parameters must be variables anyway.

	Implement versions of varset.merge_* which work with tvarsets and
	produce renamings instead of substitutions.  Renamings are more
	convenient than substitutions because we don't need to know the
	kinds of type variables in order to build the renaming, and in any
	case the substitutions shouldn't have anything other than variables
	in the range so renamings will be more efficient and safe.

	Define the type of kinds, and provide a couple of utility predicates
	to operate on them.

compiler/prog_io.m:
	Parse type definition heads as a sym_name and list of type_params,
	rather than a functor.  Handle this change in other predicates.

	Allow parse errors to be returned by get_with_type/3, and handle
	these errors.

	Remove parse_type/2.  This predicate didn't do any processing, it
	just forwarded handling to convert_type/2.

compiler/prog_io_typeclass.m:
	Change type_is_functor_and_vars to handle the new representation
	of types.  In doing so, we retain the old behaviour that pure
	predicates pass this test, but no other pred or func types.  This
	behaviour is arguably incorrect, but there is little point changing
	the behaviour at the moment.  Instead we should remove these kind of
	restrictions entirely, but that should be done later.

compiler/prog_io_util.m:
	Provide predicates to both parse and unparse types.  We need to
	unparse types before printing them out, since we do a lot of special
	case handling when printing out terms and we don't want to duplicate
	this functionality for types.

compiler/module_qual.m:
	Remove report_invalid_type.  We now report ill-formed types during
	parsing.

compiler/superhomogeneous.m:
	Handle errors from the parsing of type expressions.

compiler/prog_out.m:
	Provide a predicate to convert builtin_types to their string names,
	and vice-versa.

compiler/prog_type.m:
	Add a bunch of simple tests to use on types which may have kind
	annotations present.  In such cases, types do not have a canonical
	representation so the simple handling of these tests is not what we
	want.  (Note that these are only required in early phases.  The kind
	annotations -- when they are implemented -- will be removed before
	type checking.)

	Consistently handle the application of renamings, substitutions and
	recursive substitutions to various data structures.

compiler/mercury_to_mercury.m:
	Implement mercury_output_type, mercury_format_type and
	mercury_type_to_string.  These convert the type to a term before
	formatting -- the reason for this is so that appropriate parentheses
	are used when formatting operators.  This results in some slight
	changes to error messages, which are reflected in changes to the
	expected output files in the tests.

	Remove the old version of mercury_type_to_string.

	Change the argument ordering of mercury_format_var to be consistent
	with mercury_format_type.  (Other predicates in this module should
	probably be changed in a similar way, since this argument ordering
	is more amenable to higher-order programming.  But that can be left
	for another change.)

compiler/type_util.m:
	Implement type unification.  The behaviour is much the same as the
	previous behaviour, except that we now handle apply/N types properly,
	and we also allow for kind annotations.

	Implement an occurs check for types.

	Remove the example definition of replace_eqv_type.  It isn't used and
	would no longer work anyway even if it would have worked before.

	Add a tvar_kind_map field to ctor_defn.

	The functions type_info_type and type_ctor_info_type now return
	types with `void' as their argument, rather than the type that the
	type_info or type_ctor_info was for.

	Remove type_util.real_vars/2, since it no longer does anything
	different from prog_type.vars/2.

	Remove the commented out implementation of type_to_ctor_and_args/3.
	Its implementation is in prog_type.m, and has changed significantly
	in any case.

compiler/add_clause.m:
	Move parse_purity_annotation/3 to prog_io_util.m.

compiler/check_typeclass.m:
	Remove apply_substitution_to_var_list/3, since we now have predicates
	in prog_type.m to handle such things.

compiler/continuation_info.m:
compiler/trace.m:
	Use prog_type.vars/2 instead of type_util.real_vars/2.  The two
	predicates have the same meaning now since type_infos don't contain
	any type variables.

compiler/hlds_data.m:
	Add tvar_kind_map fields to hlds_type_defn and hlds_class_defn.

compiler/hlds_pred.m:
	Add a tvar_kind_map field to pred_info.

compiler/polymorphism.m:
	Add a tvar_kind_map field to poly_info.

	Remove unify_corresponding_types, which is no longer used.

compiler/hlds_out.m:
	Use mercury_output_type/5 instead of term_io__write_term/4 and
	mercury_output_term/5.

compiler/post_typecheck.m:
	Build the void substitution directly rather than building intermediate
	lists.

compiler/recompilation.version.m:
	Use term__list_subsumes instead of type_list_subsumes, which now
	operates only on types.  This follows up on what was suggested in
	an XXX comment.

compiler/typecheck_errors.m:
	Use unparse_type/2 to format error messages.

compiler/typecheck_info.m:
	Don't export write_type_with_bindings/5.  It is no longer used
	outside of this module.

compiler/*.m:
	Conform to the above changes.

library/rtti_implementation.m:
	Fix a syntax error that went undetected in our previous
	implementation, and amazingly enough was compiled correctly anyway.

library/term.m:
	Move the versions of term__unify, term__unify_list and
	term__list_subsumes that were implemented specifically for types
	to here.  The version of term_unify that takes a list of bound
	variables (i.e., variables that should not be bound any further)
	is used by the subsumption check, which in turn is used by
	recompilation.version.m.

tests/invalid/kind.err_exp:
tests/invalid/tc_err1.err_exp:
tests/invalid/tc_err2.err_exp:
tests/misc_tests/pretty_print_test.exp:
	Update the expected output of these tests to match what we now do.
2005-09-12 05:25:01 +00:00

569 lines
23 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1993-2005 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
:- 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(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(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 check_hlds__type_util.
:- import_module hlds__hlds_data.
:- import_module hlds__hlds_goal.
:- 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 parse_tree__error_util.
:- import_module parse_tree__prog_out.
:- import_module parse_tree__prog_type.
:- import_module parse_tree__prog_util.
:- import_module bool.
:- import_module int.
:- import_module map.
:- import_module multi_map.
:- import_module require.
:- import_module set.
:- import_module std_util.
:- import_module string.
:- import_module varset.
module_add_class_defn(Constraints, FunDeps, Name, Vars, Interface, VarSet,
Context, Status, !ModuleInfo, !IO) :-
module_info_classes(!.ModuleInfo, Classes0),
module_info_superclasses(!.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_classes(Classes, !ModuleInfo),
(
IsNewDefn = yes,
update_superclass_table(ClassId, Vars, VarSet, Constraints,
SuperClasses0, SuperClasses),
module_info_set_superclasses(SuperClasses, !ModuleInfo),
% When we find the class declaration, make an
% entry for the instances.
module_info_instances(!.ModuleInfo, Instances0),
map__det_insert(Instances0, ClassId, [], Instances),
module_info_set_instances(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([], _, _) = _ :-
error("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,
list(class_method)::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) :-
module_add_class_interface_2(Name, Vars, Methods, Status, PredProcIds0,
!ModuleInfo, !IO),
check_method_modes(Methods, PredProcIds0, PredProcIds,
!ModuleInfo, !IO).
:- pred module_add_class_interface_2(sym_name::in, list(tvar)::in,
list(class_method)::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_2(_, _, [], _, [], !ModuleInfo, !IO).
module_add_class_interface_2(Name, Vars, [M | Ms], Status, [P | Ps],
!ModuleInfo, !IO) :-
module_add_class_method(M, Name, Vars, Status, P, !ModuleInfo, !IO),
module_add_class_interface_2(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(list(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.
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.
error("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_procedures(PredInfo0, Procs),
( map__is_empty(Procs) ->
pred_method_with_no_modes_error(PredInfo0, !IO)
;
true
)
)
;
error("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_classes(!.ModuleInfo, Classes),
module_info_instances(!.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_instances(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, _)
),
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, (impure)) ->
goal_info_add_feature((impure), GoalInfo2, GoalInfo)
; check_marker(Markers, (semipure)) ->
goal_info_add_feature((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([], 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)
)
;
error("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, int::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).
:- func this_file = string.
this_file = "add_class.m".
Reference in New Issue View Git Blame Copy Permalink