[m-dev.] for review: allow clauses in instance declarations
Fergus Henderson
fjh at cs.mu.OZ.AU
Thu Sep 7 00:08:13 AEDT 2000
This is not yet complete -- in particular, I need to add
some documentation for the new feature. So I won't commit it
until it is properly documented. But I thought it was worth
posting this for review as is.
But the basic idea is to allow clauses for type class methods --
delimited by parentheses rather than periods -- within instance
declarations.
----------
Estimated hours taken: 8
Allow typeclass instance declarations to contain clauses, as an
alternative to the current `pred(<MethodName>) is <ImplName>)' syntax.
This avoids the need for the user to explicitly define names for
procedures that just implement type class methods.
XXX Note that currently we only permit one clause per method.
XXX The new feature is not yet documented.
compiler/prog_data.m:
Change the second `sym_name' field of `instance_method'
into a new type `instance_proc_def', which has two alternatives.
The first, `name(sym_name)', is for the old syntax.
The second, `clauses(list(item))', is for the new syntax.
compiler/prog_io_typeclass.m:
Parse the new syntax.
compiler/make_hlds.m:
Add new predicate `produce_instance_method_clauses',
for use by check_typeclass.m. This handles the generation of
HLDS clauses_infos for both the old and new syntax for
instance method definitions.
Return the qual_info produced by `parse_tree_to_hlds',
so that it can be passed to `produce_instance_method_clauses'.
compiler/mercury_compile.m:
Pass the qual_info returned by make_hlds.m to check_typeclass.m.
compiler/check_typeclass.m:
Move the code which produces HLDS definitions for instance
methods into `produce_instance_method_clauses' in make_hlds.m.
Thread the io__state and qual_info throughout most of the code,
since this they are needed to process the new syntax.
(The io__state is needed so we can spit out warnings about
singleton variables in clauses in type class methods, and
the qual_info is needed to handle explicit type qualifiers
in such clauses.)
compiler/mercury_to_mercury.m:
Output the new syntax.
tests/hard_coded/typeclasses/Mmakefile:
tests/hard_coded/typeclasses/instance_clauses.m:
tests/hard_coded/typeclasses/instance_clauses.exp:
A test case for the new feature.
Workspace: /home/pgrad/fjh/ws/hg
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.31
diff -u -d -r1.31 check_typeclass.m
--- compiler/check_typeclass.m 2000/07/06 06:25:07 1.31
+++ compiler/check_typeclass.m 2000/09/06 08:51:49
@@ -49,11 +49,11 @@
:- interface.
-:- import_module hlds_module, bool, io.
+:- import_module hlds_module, make_hlds, bool, io.
-:- pred check_typeclass__check_instance_decls(module_info, module_info, bool,
- io__state, io__state).
-:- mode check_typeclass__check_instance_decls(in, out, out, di, uo) is det.
+:- pred check_typeclass__check_instance_decls(module_info, qual_info,
+ module_info, bool, io__state, io__state).
+:- mode check_typeclass__check_instance_decls(in, in, out, out, di, uo) is det.
:- implementation.
@@ -66,20 +66,22 @@
:- type error_message == pair(prog_context, list(format_component)).
:- type error_messages == list(error_message).
-check_typeclass__check_instance_decls(ModuleInfo0, ModuleInfo, FoundError,
- IO0, IO) :-
+check_typeclass__check_instance_decls(ModuleInfo0, QualInfo0,
+ ModuleInfo, FoundError, IO0, IO) :-
module_info_classes(ModuleInfo0, ClassTable),
module_info_instances(ModuleInfo0, InstanceTable0),
map__to_assoc_list(InstanceTable0, InstanceList0),
- list__map_foldl(check_one_class(ClassTable), InstanceList0,
- InstanceList, [] - ModuleInfo0, Errors - ModuleInfo1),
+ list_map_foldl2(check_one_class(ClassTable), InstanceList0,
+ InstanceList, check_tc_info([], ModuleInfo0, QualInfo0),
+ check_tc_info(Errors, ModuleInfo1, _QualInfo),
+ IO0, IO1),
(
Errors = []
->
map__from_assoc_list(InstanceList, InstanceTable),
module_info_set_instances(ModuleInfo1, InstanceTable,
ModuleInfo),
- IO = IO0,
+ IO = IO1,
FoundError = no
;
ModuleInfo = ModuleInfo1,
@@ -90,21 +92,40 @@
write_error_pieces(ErrorContext, 0,
ErrorPieces, TheIO0, TheIO)
)),
- list__foldl(WriteError, ErrorList, IO0, IO1),
- io__set_exit_status(1, IO1, IO),
+ list__foldl(WriteError, ErrorList, IO1, IO2),
+ io__set_exit_status(1, IO2, IO),
FoundError = yes
).
+
+:- type check_tc_info
+ ---> check_tc_info(error_messages, module_info, qual_info).
+
+ % list__map_foldl2(Pred, InList, OutList, StartA, EndA, StartB, EndB)
+ % calls Pred with two accumulator (with the initial values of
+ % StartA and StartB respectively) on each element of InList
+ % (working left-to-right) to transform InList into OutList.
+ % The final values of the accumulators are returned in EndA
+ % and EndB respectively.
+:- pred list_map_foldl2(pred(X, Y, Z, Z, W, W), list(X), list(Y), Z, Z, W, W).
+:- mode list_map_foldl2(pred(in, out, in, out, di, uo) is det,
+ in, out, in, out, di, uo) is det.
+
+list_map_foldl2(_, [], [], A, A) -->
+ [].
+list_map_foldl2(P, [H0|T0], [H|T], A0, A) -->
+ call(P, H0, H, A0, A1),
+ list_map_foldl2(P, T0, T, A1, A).
% check all the instances of one class.
:- pred check_one_class(class_table,
pair(class_id, list(hlds_instance_defn)),
pair(class_id, list(hlds_instance_defn)),
- pair(error_messages, module_info),
- pair(error_messages, module_info)).
-:- mode check_one_class(in, in, out, in, out) is det.
+ check_tc_info, check_tc_info,
+ io__state, io__state).
+:- mode check_one_class(in, in, out, in, out, di, uo) is det.
check_one_class(ClassTable, ClassId - InstanceDefns0,
- ClassId - InstanceDefns, ModuleInfo0, ModuleInfo) :-
+ ClassId - InstanceDefns, CheckTCInfo0, CheckTCInfo, IO0, IO) :-
map__lookup(ClassTable, ClassId, ClassDefn),
ClassDefn = hlds_class_defn(_, SuperClasses, ClassVars, _,
@@ -116,23 +137,27 @@
ClassProc = hlds_class_proc(PredId, _)
)),
PredIds),
- list__map_foldl(check_class_instance(ClassId, SuperClasses, ClassVars,
+ list_map_foldl2(check_class_instance(ClassId, SuperClasses, ClassVars,
ClassInterface, ClassVarSet,
PredIds),
InstanceDefns0, InstanceDefns,
- ModuleInfo0, ModuleInfo).
+ CheckTCInfo0, CheckTCInfo,
+ IO0, IO).
% check one instance of one class
:- pred check_class_instance(class_id, list(class_constraint), list(tvar),
hlds_class_interface, tvarset, list(pred_id),
hlds_instance_defn, hlds_instance_defn,
- pair(error_messages, module_info),
- pair(error_messages, module_info)).
-:- mode check_class_instance(in, in, in, in, in, in, in, out, in, out) is det.
+ check_tc_info, check_tc_info,
+ io__state, io__state).
+:- mode check_class_instance(in, in, in, in, in, in, in, out, in, out,
+ di, uo) is det.
check_class_instance(ClassId, SuperClasses, Vars, ClassInterface, ClassVarSet,
PredIds, InstanceDefn0, InstanceDefn,
- Errors0 - ModuleInfo0, Errors - ModuleInfo):-
+ check_tc_info(Errors0, ModuleInfo0, QualInfo0),
+ check_tc_info(Errors, ModuleInfo, QualInfo),
+ IO0, IO):-
% check conformance of the instance body
InstanceDefn0 = hlds_instance_defn(_, _, _, _, InstanceBody, _, _, _),
@@ -140,16 +165,20 @@
InstanceBody = abstract,
InstanceDefn2 = InstanceDefn0,
ModuleInfo1 = ModuleInfo0,
- Errors2 = Errors0
+ QualInfo = QualInfo0,
+ Errors2 = Errors0,
+ IO = IO0
;
InstanceBody = concrete(InstanceMethods),
InstanceCheckInfo0 = instance_check_info(InstanceDefn0,
- [], Errors0, ModuleInfo0),
- list__foldl(
+ [], Errors0, ModuleInfo0, QualInfo0),
+ list__foldl2(
check_instance_pred(ClassId, Vars, ClassInterface),
- PredIds, InstanceCheckInfo0, InstanceCheckInfo),
+ PredIds, InstanceCheckInfo0, InstanceCheckInfo,
+ IO0, IO),
InstanceCheckInfo = instance_check_info(InstanceDefn1,
- RevInstanceMethods, Errors1, ModuleInfo1),
+ RevInstanceMethods, Errors1, ModuleInfo1,
+ QualInfo),
%
% We need to make sure that the MaybePredProcs field is
@@ -238,13 +267,15 @@
% order of the methods in the class
% declaration.
error_messages,
- module_info
+ module_info,
+ qual_info
).
% This structure holds the information about a particular instance
% method
:- type instance_method_info ---> instance_method_info(
module_info,
+ qual_info,
sym_name, % Name that the
% introduced pred
% should be given.
@@ -272,14 +303,16 @@
% check one pred in one instance of one class
:- pred check_instance_pred(class_id, list(tvar), hlds_class_interface,
- pred_id, instance_check_info, instance_check_info).
-:- mode check_instance_pred(in,in, in, in, in, out) is det.
+ pred_id, instance_check_info, instance_check_info,
+ io__state, io__state).
+:- mode check_instance_pred(in,in, in, in, in, out, di, uo) is det.
check_instance_pred(ClassId, ClassVars, ClassInterface, PredId,
- InstanceCheckInfo0, InstanceCheckInfo) :-
+ InstanceCheckInfo0, InstanceCheckInfo, IO0, IO) :-
InstanceCheckInfo0 = instance_check_info(InstanceDefn0,
- OrderedMethods0, Errors0, ModuleInfo0),
+ OrderedMethods0, Errors0, ModuleInfo0,
+ QualInfo0),
solutions(
lambda([ProcId::out] is nondet,
(
@@ -332,36 +365,37 @@
make_introduced_pred_name(ClassId, MethodName, PredArity,
InstanceTypes, PredName),
- Info0 = instance_method_info(ModuleInfo0, PredName, PredArity,
- ExistQVars, ArgTypes, ClassContext, ArgModes, Errors0,
- ArgTypeVars, Status, PredOrFunc),
+ Info0 = instance_method_info(ModuleInfo0, QualInfo0, PredName,
+ PredArity, ExistQVars, ArgTypes, ClassContext, ArgModes,
+ Errors0, ArgTypeVars, Status, PredOrFunc),
check_instance_pred_procs(ClassId, ClassVars, MethodName, Markers,
InstanceDefn0, InstanceDefn, OrderedMethods0, OrderedMethods,
- Info0, Info),
+ Info0, Info, IO0, IO),
- Info = instance_method_info(ModuleInfo, _PredName, _PredArity,
- _ExistQVars, _ArgTypes, _ClassContext, _ArgModes, Errors,
- _ArgTypeVars, _Status, _PredOrFunc),
+ Info = instance_method_info(ModuleInfo, QualInfo, _PredName,
+ _PredArity, _ExistQVars, _ArgTypes, _ClassContext, _ArgModes,
+ Errors, _ArgTypeVars, _Status, _PredOrFunc),
InstanceCheckInfo = instance_check_info(InstanceDefn,
- OrderedMethods, Errors, ModuleInfo).
+ OrderedMethods, Errors, ModuleInfo, QualInfo).
:- pred check_instance_pred_procs(class_id, list(tvar), sym_name, pred_markers,
hlds_instance_defn, hlds_instance_defn,
instance_methods, instance_methods,
- instance_method_info, instance_method_info).
+ instance_method_info, instance_method_info,
+ io__state, io__state).
:- mode check_instance_pred_procs(in, in, in, in, in, out,
- in, out, in, out) is det.
+ in, out, in, out, di, uo) is det.
check_instance_pred_procs(ClassId, ClassVars, MethodName, Markers,
InstanceDefn0, InstanceDefn, OrderedInstanceMethods0,
- OrderedInstanceMethods, Info0, Info) :-
+ OrderedInstanceMethods, Info0, Info, IO0, IO) :-
InstanceDefn0 = hlds_instance_defn(A, InstanceContext,
InstanceConstraints, InstanceTypes,
InstanceBody, MaybeInstancePredProcs,
InstanceVarSet, H),
- Info0 = instance_method_info(ModuleInfo, PredName, PredArity,
+ Info0 = instance_method_info(ModuleInfo, QualInfo, PredName, PredArity,
ExistQVars, ArgTypes, ClassContext, ArgModes, Errors0,
ArgTypeVars, Status, PredOrFunc),
get_matching_instance_names(InstanceBody, PredOrFunc, MethodName,
@@ -371,13 +405,14 @@
->
OrderedInstanceMethods =
[InstanceMethod | OrderedInstanceMethods0],
- InstanceMethod = instance_method(_, _, InstancePredName,
+ InstanceMethod = instance_method(_, _, InstancePredDefn,
_, Context),
produce_auxiliary_procs(ClassVars, Markers,
InstanceTypes, InstanceConstraints,
InstanceVarSet,
- InstancePredName, Context,
- InstancePredId, InstanceProcIds, Info0, Info),
+ InstancePredDefn, Context,
+ InstancePredId, InstanceProcIds, Info0, Info,
+ IO0, IO),
MakeClassProc =
lambda([TheProcId::in, PredProcId::out] is det,
@@ -439,9 +474,10 @@
% errors are built up in reverse.
list__append(SubsequentErrors, Heading, NewErrors),
list__append(NewErrors, Errors0, Errors),
- Info = instance_method_info(ModuleInfo, PredName, PredArity,
- ExistQVars, ArgTypes, ClassContext, ArgModes, Errors,
- ArgTypeVars, Status, PredOrFunc)
+ Info = instance_method_info(ModuleInfo, QualInfo, PredName,
+ PredArity, ExistQVars, ArgTypes, ClassContext,
+ ArgModes, Errors, ArgTypeVars, Status, PredOrFunc),
+ IO = IO0
;
% another kind of error
OrderedInstanceMethods = OrderedInstanceMethods0,
@@ -469,9 +505,11 @@
MethodNameString, "/", PredArityString, "'."],
NewError),
Errors = [InstanceContext - [words(NewError)] | Errors0],
- Info = instance_method_info(ModuleInfo, PredName, PredArity,
- ExistQVars, ArgTypes, ClassContext, ArgModes, Errors,
- ArgTypeVars, Status, PredOrFunc)
+ Info = instance_method_info(ModuleInfo, QualInfo, PredName,
+ PredArity, ExistQVars, ArgTypes, ClassContext,
+ ArgModes, Errors,
+ ArgTypeVars, Status, PredOrFunc),
+ IO = IO0
).
:- pred get_matching_instance_names(instance_body, pred_or_func,
@@ -486,7 +524,7 @@
InstanceBody = concrete(InstanceMethods),
list__member(Method, InstanceMethods),
Method = instance_method(PredOrFunc,
- MethodName, _InstanceMethodName,
+ MethodName, _InstanceMethodDefn,
MethodArity, _Context)
),
MatchingInstanceMethods).
@@ -494,20 +532,21 @@
% Just a bit simpler than using a pair of pairs
:- type triple(T1, T2, T3) ---> triple(T1, T2, T3).
-:- pred produce_auxiliary_procs(list(tvar), pred_markers,
- list(type), list(class_constraint), tvarset, sym_name, prog_context,
- pred_id, list(proc_id), instance_method_info, instance_method_info).
+:- pred produce_auxiliary_procs(list(tvar), pred_markers, list(type),
+ list(class_constraint), tvarset, instance_proc_def, prog_context,
+ pred_id, list(proc_id), instance_method_info, instance_method_info,
+ io__state, io__state).
:- mode produce_auxiliary_procs(in, in, in, in, in, in, in, out, out,
- in, out) is det.
+ in, out, di, uo) is det.
produce_auxiliary_procs(ClassVars, Markers0,
InstanceTypes0, InstanceConstraints0, InstanceVarSet,
- InstancePredName, Context, PredId,
- InstanceProcIds, Info0, Info) :-
+ InstancePredDefn, Context, PredId,
+ InstanceProcIds, Info0, Info, IO0, IO) :-
- Info0 = instance_method_info(ModuleInfo0, PredName, PredArity,
- ExistQVars0, ArgTypes0, ClassContext0, ArgModes, Errors,
- ArgTypeVars0, Status0, PredOrFunc),
+ Info0 = instance_method_info(ModuleInfo0, QualInfo0, PredName,
+ PredArity, ExistQVars0, ArgTypes0, ClassContext0, ArgModes,
+ Errors, ArgTypeVars0, Status0, PredOrFunc),
% Rename the instance variables apart from the class variables
varset__merge_subst(ArgTypeVars0, InstanceVarSet, ArgTypeVars1,
@@ -551,17 +590,11 @@
module_info_globals(ModuleInfo0, Globals),
globals__lookup_string_option(Globals, aditi_user, User),
- % We have to add the actual clause after we have added the
- % procs because we need a list of proc numbers for which the
- % clauses holds.
- DummyClause = [],
- varset__init(VarSet0),
- make_n_fresh_vars("HeadVar__", PredArity, VarSet0, HeadVars, VarSet),
- map__from_corresponding_lists(HeadVars, ArgTypes, VarTypes),
- map__init(TI_VarMap),
- map__init(TCI_VarMap),
- ClausesInfo0 = clauses_info(VarSet, VarTypes, VarTypes, HeadVars,
- DummyClause, TI_VarMap, TCI_VarMap),
+ produce_instance_method_clauses(InstancePredDefn, PredOrFunc,
+ PredArity, ArgTypes, Markers, Context, ClausesInfo,
+ ModuleInfo0, ModuleInfo1, QualInfo0, QualInfo, IO0, IO),
+
+ pred_info_set_clauses_info(PredInfo1, ClausesInfo, PredInfo),
( status_is_imported(Status0, yes) ->
Status = opt_imported
@@ -570,7 +603,7 @@
),
pred_info_init(ModuleName, PredName, PredArity, ArgTypeVars,
- ExistQVars, ArgTypes, Cond, Context, ClausesInfo0, Status,
+ ExistQVars, ArgTypes, Cond, Context, ClausesInfo, Status,
Markers, none, PredOrFunc, ClassContext, Proofs, User,
PredInfo0),
@@ -586,58 +619,17 @@
list__map_foldl(AddProc, ArgModes, InstanceProcIds,
PredInfo0, PredInfo1),
- % Add the body of the introduced pred
-
- % First the goal info
- goal_info_init(GoalInfo0),
- goal_info_set_context(GoalInfo0, Context, GoalInfo1),
- set__list_to_set(HeadVars, NonLocals),
- goal_info_set_nonlocals(GoalInfo1, NonLocals, GoalInfo2),
- (
- check_marker(Markers, (impure))
- ->
- goal_info_add_feature(GoalInfo2, (impure), GoalInfo)
- ;
- check_marker(Markers, (semipure))
- ->
- goal_info_add_feature(GoalInfo2, (semipure), GoalInfo)
- ;
- GoalInfo = GoalInfo2
- ),
-
- % Then the goal itself
- invalid_pred_id(InvalidPredId),
- invalid_proc_id(InvalidProcId),
- (
- PredOrFunc = predicate,
- Call = call(InvalidPredId, InvalidProcId, HeadVars, not_builtin,
- no, InstancePredName),
- IntroducedGoal = Call - GoalInfo
- ;
- PredOrFunc = function,
- pred_args_to_func_args(HeadVars, RealHeadVars, ReturnVar),
- create_atomic_unification(ReturnVar,
- functor(cons(InstancePredName, PredArity),
- RealHeadVars),
- Context, explicit, [], IntroducedGoal0),
- % set the goal_info
- IntroducedGoal0 = IntroducedGoalExpr - _,
- IntroducedGoal = IntroducedGoalExpr - GoalInfo
- ),
- IntroducedClause = clause(InstanceProcIds, IntroducedGoal, Context),
- clauses_info_set_clauses(ClausesInfo0, [IntroducedClause], ClausesInfo),
- pred_info_set_clauses_info(PredInfo1, ClausesInfo, PredInfo),
- module_info_get_predicate_table(ModuleInfo0, PredicateTable0),
- module_info_get_partial_qualifier_info(ModuleInfo0, PQInfo),
+ module_info_get_predicate_table(ModuleInfo1, PredicateTable1),
+ module_info_get_partial_qualifier_info(ModuleInfo1, PQInfo),
% XXX why do we need to pass may_be_unqualified here,
% rather than passing must_be_qualified or calling the /4 version?
- predicate_table_insert(PredicateTable0, PredInfo,
+ predicate_table_insert(PredicateTable1, PredInfo,
may_be_unqualified, PQInfo, PredId, PredicateTable),
- module_info_set_predicate_table(ModuleInfo0, PredicateTable,
+ module_info_set_predicate_table(ModuleInfo1, PredicateTable,
ModuleInfo),
- Info = instance_method_info(ModuleInfo, PredName, PredArity,
+ Info = instance_method_info(ModuleInfo, QualInfo, PredName, PredArity,
ExistQVars, ArgTypes, ClassContext, ArgModes, Errors,
ArgTypeVars, Status, PredOrFunc).
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.344
diff -u -d -r1.344 make_hlds.m
--- compiler/make_hlds.m 2000/08/25 06:06:59 1.344
+++ compiler/make_hlds.m 2000/09/06 12:18:56
@@ -27,15 +27,18 @@
:- import_module io, std_util, list, bool.
-% parse_tree_to_hlds(ParseTree, MQInfo, EqvMap, HLDS, UndefTypes, UndefModes):
+% parse_tree_to_hlds(ParseTree, MQInfo, EqvMap, HLDS, QualInfo,
+% UndefTypes, UndefModes):
% Given MQInfo (returned by module_qual.m) and EqvMap (returned by
% equiv_type.m), converts ParseTree to HLDS.
% Any errors found are recorded in the HLDS num_errors field.
% Returns UndefTypes = yes if undefined types found.
% Returns UndefModes = yes if undefined modes found.
+% QualInfo is an abstract type that is then passed back to
+% produce_instance_method_clauses (see below).
:- pred parse_tree_to_hlds(compilation_unit, mq_info, eqv_map, module_info,
- bool, bool, io__state, io__state).
-:- mode parse_tree_to_hlds(in, in, in, out, out, out, di, uo) is det.
+ qual_info, bool, bool, io__state, io__state).
+:- mode parse_tree_to_hlds(in, in, in, out, out, out, out, di, uo) is det.
:- pred add_new_proc(pred_info, arity, list(mode), maybe(list(mode)),
maybe(list(is_live)), maybe(determinism),
@@ -44,6 +47,18 @@
:- pred clauses_info_init(int::in, clauses_info::out) is det.
+:- type qual_info.
+
+ % Given the definition for a predicate or function from a
+ % type class instance declaration, produce the clauses_info
+ % for that definition.
+:- pred produce_instance_method_clauses(instance_proc_def::in,
+ pred_or_func::in, arity::in, list(type)::in, pred_markers::in,
+ term__context::in, clauses_info::out,
+ module_info::in, module_info::out,
+ qual_info::in, qual_info::out,
+ io__state::di, io__state::uo) is det.
+
:- pred next_mode_id(proc_table, maybe(determinism), proc_id).
:- mode next_mode_id(in, in, out) is det.
@@ -64,7 +79,7 @@
:- import_module string, char, int, set, bintree, map, multi_map, require.
:- import_module bag, term, varset, getopt, assoc_list, term_io.
-parse_tree_to_hlds(module(Name, Items), MQInfo0, EqvMap, Module,
+parse_tree_to_hlds(module(Name, Items), MQInfo0, EqvMap, Module, QualInfo,
UndefTypes, UndefModes) -->
globals__io_get_globals(Globals),
{ mq_info_get_partial_qualifier_info(MQInfo0, PQInfo) },
@@ -79,10 +94,10 @@
% balance the binary trees
{ module_info_optimize(Module2, Module3) },
maybe_report_stats(Statistics),
- { init_qual_info(MQInfo0, EqvMap, Info0) },
+ { init_qual_info(MQInfo0, EqvMap, QualInfo0) },
add_item_list_clauses(Items, local, Module3, Module4,
- Info0, Info),
- { qual_info_get_mq_info(Info, MQInfo) },
+ QualInfo0, QualInfo),
+ { qual_info_get_mq_info(QualInfo, MQInfo) },
{ mq_info_get_type_error_flag(MQInfo, UndefTypes) },
{ mq_info_get_mode_error_flag(MQInfo, UndefModes) },
{ mq_info_get_num_errors(MQInfo, MQ_NumErrors) },
@@ -3579,6 +3594,122 @@
;
[]
)
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Generate the clauses_info for the introduced predicate that we generate
+% for each method in a type class instance declaration.
+%
+
+ % handle the `pred(<MethodName>/<Arity>) is <ImplName>' syntax
+produce_instance_method_clauses(name(InstancePredName), PredOrFunc, PredArity,
+ ArgTypes, Markers, Context, ClausesInfo,
+ ModuleInfo, ModuleInfo, QualInfo, QualInfo, IO, IO) :-
+
+ % Add the body of the introduced pred
+
+ % First the goal info
+ goal_info_init(GoalInfo0),
+ goal_info_set_context(GoalInfo0, Context, GoalInfo1),
+ set__list_to_set(HeadVars, NonLocals),
+ goal_info_set_nonlocals(GoalInfo1, NonLocals, GoalInfo2),
+ (
+ check_marker(Markers, (impure))
+ ->
+ goal_info_add_feature(GoalInfo2, (impure), GoalInfo)
+ ;
+ check_marker(Markers, (semipure))
+ ->
+ goal_info_add_feature(GoalInfo2, (semipure), GoalInfo)
+ ;
+ GoalInfo = GoalInfo2
+ ),
+
+ % Then the goal itself
+ varset__init(VarSet0),
+ make_n_fresh_vars("HeadVar__", PredArity, VarSet0, HeadVars, VarSet),
+ invalid_pred_id(InvalidPredId),
+ invalid_proc_id(InvalidProcId),
+ (
+ PredOrFunc = predicate,
+ Call = call(InvalidPredId, InvalidProcId, HeadVars, not_builtin,
+ no, InstancePredName),
+ IntroducedGoal = Call - GoalInfo
+ ;
+ PredOrFunc = function,
+ pred_args_to_func_args(HeadVars, RealHeadVars, ReturnVar),
+ create_atomic_unification(ReturnVar,
+ functor(cons(InstancePredName, PredArity),
+ RealHeadVars),
+ Context, explicit, [], IntroducedGoal0),
+ % set the goal_info
+ IntroducedGoal0 = IntroducedGoalExpr - _,
+ IntroducedGoal = IntroducedGoalExpr - GoalInfo
+ ),
+ IntroducedClause = clause([], IntroducedGoal, Context),
+
+ map__from_corresponding_lists(HeadVars, ArgTypes, VarTypes),
+ map__init(TI_VarMap),
+ map__init(TCI_VarMap),
+ ClausesInfo = clauses_info(VarSet, VarTypes, VarTypes, HeadVars,
+ [IntroducedClause], TI_VarMap, TCI_VarMap).
+
+ % handle the arbitrary clauses syntax
+produce_instance_method_clauses(clauses(InstanceClauses), PredOrFunc,
+ PredArity, _ArgTypes, _Markers, Context, ClausesInfo,
+ ModuleInfo0, ModuleInfo, QualInfo0, QualInfo, IO0, IO) :-
+ clauses_info_init(PredArity, ClausesInfo0),
+ list__foldl2(produce_instance_method_clause(PredOrFunc, Context),
+ InstanceClauses, ModuleInfo0 - QualInfo0 - ClausesInfo0,
+ ModuleInfo - QualInfo - ClausesInfo, IO0, IO).
+
+:- pred produce_instance_method_clause(pred_or_func::in,
+ prog_context::in, item::in,
+ pair(pair(module_info, qual_info), clauses_info)::in,
+ pair(pair(module_info, qual_info), clauses_info)::out,
+ io__state::di, io__state::uo) is det.
+produce_instance_method_clause(PredOrFunc, Context, InstanceClause,
+ ModuleInfo0 - QualInfo0 - ClausesInfo0,
+ ModuleInfo - QualInfo - ClausesInfo) -->
+ (
+ {
+ PredOrFunc = predicate,
+ InstanceClause = pred_clause(CVarSet, PredName,
+ HeadTerms, Body),
+ Arity = list__length(HeadTerms)
+ ;
+ PredOrFunc = function,
+ InstanceClause = func_clause(CVarSet, PredName,
+ ArgTerms, ResultTerm, Body),
+ HeadTerms = list__append(ArgTerms, [ResultTerm]),
+ Arity = list__length(ArgTerms)
+ }
+ ->
+ % currently these two arguments are not used
+ % in any important way, I think, so I think
+ % we can safely set them to dummy values
+ { invalid_pred_id(PredId) },
+ { varset__init(TVarSet0) },
+
+ { ModeIds = [] }, % means this clause applies to _every_
+ % mode of the procedure
+ { IsAssertion = no },
+ clauses_info_add_clause(ClausesInfo0, PredId, ModeIds,
+ CVarSet, TVarSet0, HeadTerms, Body, Context,
+ PredOrFunc, Arity, IsAssertion, Goal,
+ VarSet, _TVarSet, ClausesInfo, Warnings,
+ ModuleInfo0, ModuleInfo, QualInfo0, QualInfo),
+
+ % warn about singleton variables
+ maybe_warn_singletons(VarSet,
+ PredOrFunc - PredName/Arity, ModuleInfo, Goal),
+
+ % warn about variables with overlapping scopes
+ maybe_warn_overlap(Warnings, VarSet,
+ PredOrFunc - PredName/Arity)
+ ;
+ { error("produce_clause: invalid instance item") }
).
%-----------------------------------------------------------------------------%
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.171
diff -u -d -r1.171 mercury_compile.m
--- compiler/mercury_compile.m 2000/08/11 08:19:12 1.171
+++ compiler/mercury_compile.m 2000/09/06 09:08:57
@@ -396,9 +396,9 @@
% If we are only typechecking or error checking, then we should not
% modify any files, this includes writing to .d files.
mercury_compile__pre_hlds_pass(Module, DontWriteDFile,
- HLDS1, UndefTypes, UndefModes, Errors1),
- mercury_compile__frontend_pass(HLDS1, HLDS20, UndefTypes,
- UndefModes, Errors2),
+ HLDS1, QualInfo, UndefTypes, UndefModes, Errors1),
+ mercury_compile__frontend_pass(HLDS1, QualInfo, UndefTypes,
+ UndefModes, HLDS20, Errors2),
( { Errors1 = no }, { Errors2 = no } ->
globals__io_lookup_bool_option(verbose, Verbose),
globals__io_lookup_bool_option(statistics, Stats),
@@ -480,12 +480,13 @@
%-----------------------------------------------------------------------------%
:- pred mercury_compile__pre_hlds_pass(module_imports, bool,
- module_info, bool, bool, bool, io__state, io__state).
-:- mode mercury_compile__pre_hlds_pass(in, in, out, out, out, out,
+ module_info, qual_info, bool, bool, bool,
+ io__state, io__state).
+:- mode mercury_compile__pre_hlds_pass(in, in, out, out, out, out, out,
di, uo) is det.
mercury_compile__pre_hlds_pass(ModuleImports0, DontWriteDFile,
- HLDS1, UndefTypes, UndefModes, FoundError) -->
+ HLDS1, QualInfo, UndefTypes, UndefModes, FoundError) -->
globals__io_lookup_bool_option(statistics, Stats),
globals__io_lookup_bool_option(verbose, Verbose),
@@ -514,7 +515,8 @@
{ bool__or(UndefTypes0, CircularTypes, UndefTypes1) },
mercury_compile__make_hlds(Module, Items, MQInfo, EqvMap, Verbose,
- Stats, HLDS0, UndefTypes2, UndefModes2, FoundError),
+ Stats, HLDS0, QualInfo,
+ UndefTypes2, UndefModes2, FoundError),
{ bool__or(UndefTypes1, UndefTypes2, UndefTypes) },
{ bool__or(UndefModes0, UndefModes2, UndefModes) },
@@ -644,15 +646,17 @@
maybe_report_stats(Stats).
:- pred mercury_compile__make_hlds(module_name, item_list, mq_info, eqv_map,
- bool, bool, module_info, bool, bool, bool, io__state, io__state).
+ bool, bool, module_info, qual_info, bool, bool, bool,
+ io__state, io__state).
:- mode mercury_compile__make_hlds(in, in, in, in, in, in,
- out, out, out, out, di, uo) is det.
+ out, out, out, out, out, di, uo) is det.
mercury_compile__make_hlds(Module, Items, MQInfo, EqvMap, Verbose, Stats,
- HLDS, UndefTypes, UndefModes, FoundSemanticError) -->
+ HLDS, QualInfo, UndefTypes, UndefModes, FoundSemanticError) -->
maybe_write_string(Verbose, "% Converting parse tree to hlds...\n"),
{ Prog = module(Module, Items) },
- parse_tree_to_hlds(Prog, MQInfo, EqvMap, HLDS, UndefTypes, UndefModes),
+ parse_tree_to_hlds(Prog, MQInfo, EqvMap, HLDS, QualInfo,
+ UndefTypes, UndefModes),
{ module_info_num_errors(HLDS, NumErrors) },
( { NumErrors > 0 } ->
{ FoundSemanticError = yes },
@@ -666,13 +670,15 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-:- pred mercury_compile__frontend_pass(module_info, module_info, bool,
- bool, bool, io__state, io__state).
-% :- mode mercury_compile__frontend_pass(di, uo, in, in, out, di, uo) is det.
-:- mode mercury_compile__frontend_pass(in, out, in, in, out, di, uo) is det.
+:- pred mercury_compile__frontend_pass(module_info, qual_info, bool, bool,
+ module_info, bool, io__state, io__state).
+% :- mode mercury_compile__frontend_pass(di, in, in, in, uo, out, di, uo)
+% is det.
+:- mode mercury_compile__frontend_pass(in, in, in, in, out, out, di, uo)
+ is det.
-mercury_compile__frontend_pass(HLDS1, HLDS, FoundUndefTypeError,
- FoundUndefModeError, FoundError) -->
+mercury_compile__frontend_pass(HLDS1, QualInfo, FoundUndefTypeError,
+ FoundUndefModeError, HLDS, FoundError) -->
%
% We can't continue after an undefined type error, since
% typecheck would get internal errors
@@ -690,7 +696,7 @@
maybe_write_string(Verbose,
"% Checking typeclass instances...\n"),
- check_typeclass__check_instance_decls(HLDS1, HLDS2,
+ check_typeclass__check_instance_decls(HLDS1, QualInfo, HLDS2,
FoundTypeclassError),
mercury_compile__maybe_dump_hlds(HLDS2, "02", "typeclass"),
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.172
diff -u -d -r1.172 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 2000/08/13 13:18:44 1.172
+++ compiler/mercury_to_mercury.m 2000/09/06 12:29:46
@@ -31,6 +31,8 @@
io__state, io__state).
:- mode convert_to_mercury(in, in, in, di, uo) is det.
+% mercury_output_item(Item, Context)
+% output the specified item, followed by ".\n"
:- pred mercury_output_item(item, prog_context, io__state, io__state).
:- mode mercury_output_item(in, in, di, uo) is det.
@@ -305,13 +307,15 @@
mercury_output_item(pred_clause(VarSet, PredName, Args, Body), Context) -->
maybe_output_line_number(Context),
- mercury_output_pred_clause(VarSet, PredName, Args, Body, Context).
+ mercury_output_pred_clause(VarSet, PredName, Args, Body, Context),
+ io__write_string(".\n").
mercury_output_item(func_clause(VarSet, FuncName, Args, Result, Body),
Context) -->
maybe_output_line_number(Context),
mercury_output_func_clause(VarSet, FuncName, Args, Result, Body,
- Context).
+ Context),
+ io__write_string(".\n").
mercury_output_item(pragma(Pragma), Context) -->
maybe_output_line_number(Context),
@@ -533,20 +537,57 @@
:- mode output_instance_method(in, di, uo) is det.
output_instance_method(Method) -->
- io__write_char('\t'),
- { Method = instance_method(PredOrFunc, Name1, Name2, Arity, _Context) },
+ { Method = instance_method(PredOrFunc, Name1, Defn, Arity, Context) },
(
- { PredOrFunc = function },
- io__write_string("func(")
+ { Defn = name(Name2) },
+ io__write_char('\t'),
+ (
+ { PredOrFunc = function },
+ io__write_string("func(")
+ ;
+ { PredOrFunc = predicate },
+ io__write_string("pred(")
+ ),
+ mercury_output_bracketed_sym_name(Name1, next_to_graphic_token),
+ io__write_string("/"),
+ io__write_int(Arity),
+ io__write_string(") is "),
+ mercury_output_bracketed_sym_name(Name2)
;
- { PredOrFunc = predicate },
- io__write_string("pred(")
- ),
- mercury_output_bracketed_sym_name(Name1, next_to_graphic_token),
- io__write_string("/"),
- io__write_int(Arity),
- io__write_string(") is "),
- mercury_output_bracketed_sym_name(Name2).
+ { Defn = clauses(ItemList) },
+ % XXX should we output the term contexts?
+ io__write_string("\t("),
+ (
+ { PredOrFunc = predicate },
+ { WriteOneItem = (pred(Item::in, di, uo) is det -->
+ (
+ { Item = pred_clause(VarSet, _PredName,
+ HeadTerms, Body) }
+ ->
+ mercury_output_pred_clause(VarSet,
+ Name1, HeadTerms, Body,
+ Context)
+ ;
+ { error("invalid instance item") }
+ )) },
+ io__write_list(ItemList, "),\n\t(", WriteOneItem)
+ ;
+ { PredOrFunc = function },
+ { WriteOneItem = (pred(Item::in, di, uo) is det -->
+ (
+ { Item = func_clause(VarSet, _PredName,
+ ArgTerms, ResultTerm, Body) }
+ ->
+ mercury_output_func_clause(VarSet,
+ Name1, ArgTerms, ResultTerm,
+ Body, Context)
+ ;
+ { error("invalid instance item") }
+ )) },
+ io__write_list(ItemList, "),\n\t(", WriteOneItem)
+ ),
+ io__write_string(")")
+ ).
%-----------------------------------------------------------------------------%
@@ -1723,8 +1764,7 @@
;
io__write_string(" :-\n\t"),
mercury_output_goal(Body, VarSet, 1)
- ),
- io__write_string(".\n").
+ ).
% Output an equation.
@@ -1753,8 +1793,7 @@
mercury_output_term(Result, VarSet, no),
io__write_string(" :-\n\t"),
mercury_output_goal(Body, VarSet, 1)
- ),
- io__write_string(".\n").
+ ).
:- pred mercury_output_goal(goal, prog_varset, int, io__state, io__state).
:- mode mercury_output_goal(in, in, in, di, uo) is det.
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.57
diff -u -d -r1.57 prog_data.m
--- compiler/prog_data.m 2000/08/09 07:47:41 1.57
+++ compiler/prog_data.m 2000/09/06 04:10:53
@@ -487,10 +487,21 @@
.
:- type instance_method
- ---> instance_method(pred_or_func, sym_name,
- sym_name, arity, prog_context).
+ ---> instance_method(pred_or_func, sym_name, instance_proc_def,
+ arity, prog_context).
% PredOrFunc, Method, Instance, Arity,
% Line number of declaration
+
+:- type instance_proc_def
+ % defined using the `pred(...) is <Name>' syntax
+ ---> name(sym_name)
+
+ % defined using clauses
+ ; clauses(
+ list(item) % the items must be either
+ % pred_clause or func_clause items
+ )
+ .
:- type instance_body
---> abstract
Index: compiler/prog_io_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_typeclass.m,v
retrieving revision 1.15
diff -u -d -r1.15 prog_io_typeclass.m
--- compiler/prog_io_typeclass.m 2000/08/16 08:54:06 1.15
+++ compiler/prog_io_typeclass.m 2000/09/06 05:12:03
@@ -355,7 +355,7 @@
(
Arg = term__functor(term__atom("where"), [Name, Methods], _)
->
- parse_non_empty_instance(ModuleName, Name, Methods,
+ parse_non_empty_instance(ModuleName, Name, Methods, VarSet,
TVarSet, Result)
;
parse_instance_name(ModuleName, Arg, TVarSet, Result)
@@ -472,12 +472,12 @@
Result = error(String, Term)
).
-:- pred parse_non_empty_instance(module_name, term, term, tvarset,
+:- pred parse_non_empty_instance(module_name, term, term, varset, tvarset,
maybe1(item)).
-:- mode parse_non_empty_instance(in, in, in, in, out) is det.
+:- mode parse_non_empty_instance(in, in, in, in, in, out) is det.
-parse_non_empty_instance(ModuleName, Name, Methods, TVarSet, Result) :-
- parse_instance_methods(ModuleName, Methods, ParsedMethods),
+parse_non_empty_instance(ModuleName, Name, Methods, VarSet, TVarSet, Result) :-
+ parse_instance_methods(ModuleName, Methods, VarSet, ParsedMethods),
(
ParsedMethods = ok(MethodList),
parse_instance_name(ModuleName, Name, TVarSet,
@@ -531,17 +531,17 @@
error("check_tvars_in_constraint: expecting instance item")
).
-:- pred parse_instance_methods(module_name, term,
+:- pred parse_instance_methods(module_name, term, varset,
maybe1(list(instance_method))).
-:- mode parse_instance_methods(in, in, out) is det.
+:- mode parse_instance_methods(in, in, in, out) is det.
-parse_instance_methods(ModuleName, Methods, Result) :-
+parse_instance_methods(ModuleName, Methods, VarSet, Result) :-
(
list_term_to_term_list(Methods, MethodList)
->
% Convert the list of terms into a list of
% maybe1(class_method)s.
- list__map(term_to_instance_method(ModuleName),
+ list__map(term_to_instance_method(ModuleName, VarSet),
MethodList, Interface),
find_errors(Interface, Result)
;
@@ -549,10 +549,11 @@
).
% Turn the term into a method instance
-:- pred term_to_instance_method(module_name, term, maybe1(instance_method)).
-:- mode term_to_instance_method(in, in, out) is det.
+:- pred term_to_instance_method(module_name, varset, term,
+ maybe1(instance_method)).
+:- mode term_to_instance_method(in, in, in, out) is det.
-term_to_instance_method(_ModuleName, MethodTerm, Result) :-
+term_to_instance_method(ModuleName, VarSet, MethodTerm, Result) :-
(
MethodTerm = term__functor(term__atom("is"), [ClassMethodTerm,
InstanceMethod], TermContext)
@@ -576,7 +577,8 @@
ok(InstanceMethodName, []))
->
Result = ok(instance_method(predicate,
- ClassMethodName, InstanceMethodName,
+ ClassMethodName,
+ name(InstanceMethodName),
ArityInt, TermContext))
;
Result = error(
@@ -602,7 +604,8 @@
ok(InstanceMethodName, []))
->
Result = ok(instance_method(function,
- ClassMethodName, InstanceMethodName,
+ ClassMethodName,
+ name(InstanceMethodName),
ArityInt, TermContext))
;
Result = error(
@@ -615,7 +618,29 @@
MethodTerm)
)
;
- Result = error("expected `pred(<Name> / <Arity>) is <InstanceName>'",
- MethodTerm)
+ parse_item(ModuleName, VarSet, MethodTerm, Result0),
+ (
+ Result0 = ok(Item, Context),
+ (
+ Item = pred_clause(_VarNames, ClassMethodName,
+ HeadArgs, _ClauseBody),
+ PredOrFunc = predicate,
+ ArityInt = list__length(HeadArgs)
+ ;
+ Item = func_clause(_VarNames, ClassMethodName,
+ FuncArgs, _Result, _ClauseBody),
+ ArityInt = list__length(FuncArgs),
+ PredOrFunc = function
+ )
+ ->
+ Result = ok(instance_method(PredOrFunc,
+ ClassMethodName,
+ % XXX FIXME handle multiple clauses
+ clauses([Item]),
+ ArityInt, Context))
+ ;
+ Result = error("expected clause or `pred(<Name> / <Arity>) is <InstanceName>' or `func(<Name> / <Arity>) is <InstanceName>')",
+ MethodTerm)
+ )
).
Index: tests/hard_coded/typeclasses/instance_clauses.exp
===================================================================
RCS file: instance_clauses.exp
diff -N instance_clauses.exp
--- /dev/null Thu Mar 30 14:06:13 2000
+++ instance_clauses.exp Wed Sep 6 23:33:08 2000
@@ -0,0 +1,2 @@
+[1, 2, 3]
+[101]
Index: tests/hard_coded/typeclasses/instance_clauses.m
===================================================================
RCS file: instance_clauses.m
diff -N instance_clauses.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ instance_clauses.m Wed Sep 6 23:23:17 2000
@@ -0,0 +1,49 @@
+:- module instance_clauses.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- import_module std_util.
+
+:- typeclass thisclass(T) where [
+ pred c(T, T),
+ mode c(in, in) is semidet,
+ mode c(out, in) is semidet,
+ mode c(in, out) is nondet,
+
+ pred d(T, T),
+ mode d(in, in) is semidet,
+ mode d(out, in) is semidet,
+ mode d(in, out) is nondet
+].
+
+:- instance thisclass(int) where [
+ (c(X, Y) :-
+ ( X = 1, Y = 1
+ ; X = 1, Y = 2
+ ; X = 1, Y = 3
+ ; X = 2, Y = 4
+ )),
+ d(42, 101)
+% d(42, 102),
+% d(43, 102)
+].
+
+:- pred mypred(T, T) <= thisclass(T).
+:- mode mypred(in, out) is nondet.
+mypred(A, B) :- c(A, B).
+
+:- pred mypred2(T, T) <= thisclass(T).
+:- mode mypred2(in, out) is nondet.
+mypred2(A, B) :- d(A, B).
+
+main -->
+ { solutions(mypred(1), X) },
+ io__write(X), nl,
+ { solutions(mypred2(42), Y) },
+ io__write(Y), nl.
Index: tests/hard_coded/typeclasses/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/typeclasses/Mmakefile,v
retrieving revision 1.30
diff -u -d -r1.30 Mmakefile
--- tests/hard_coded/typeclasses/Mmakefile 2000/07/06 06:25:24 1.30
+++ tests/hard_coded/typeclasses/Mmakefile 2000/09/06 12:33:31
@@ -23,6 +23,7 @@
implied_instance_missing_constraint \
implied_instance_poly \
impure_methods \
+ instance_clauses \
instance_unconstrained_tvar \
inference_test \
inference_test_2 \
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh> | of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3 | -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list