extending "univ" to typeclasses

[David Glen JEFFERY]

Hi all,

Here's an idea that I thought I'd share:

At the moment, we have a type called "univ" which stores values of any type.
Conceptually, it could be defined as:

:- type univ ---> some [T] univ(T).

The problem with doing so is, of course, that don't yet support
existentially quantified components of data structures. As I showed in the
Mercury meeting a couple of weeks ago, adding the machinery for doing so is
a non-trivial task (which we're working towards... but it will take time).

However, with the arrival of existentially typed *predicates*, we now have
something like:

:- some [T] pred univ_value(univ::in, T::out) is det.

It deconstructs a univ and gives you back a value *of unknown type*.
The implementation of this predicate is quite simple using the C interface.
It cannot, however, be written in Mercury at the moment.

So... onto my point. It would be nice to be able to build data structures
which contain values which are of different type (which you can do with
univ), but which are all constrained to belong to some type class (which you
can't do with univ). When I take something out of the data structureI should
get something whose type I don't know (just like univ_value), but I know
that I can perform all of a particular type class's operations on it (unlike
univ_value).

What I propose is a mechanism for *generating* a type just like univ, except
that the values stored in it would be known to belong to a particular type
class.  Although this isn't the most elegant solution, I think it is a nice
interim measure until the existential types implementation is complete (ie.
allowing existentially quantified components in data structures). I believe
that this will make existential types much more useful in their current
state.

As an example of the translation, given:

:- typeclass c(T) where [
	...
].

We can generate a type:

:- type c_object.

:- pred construct_c_object(T, c_object) <= c(T).
:- mode construct_c_object(in, out) is det.

:- some [T] (pred deconstruct_c_object(T, c_object) & c(T)).
:- mode deconstruct_c_object(out, in) is det.

The implementations of these two primitives is, using the C interface, quite
simple. Essentially what they are doing is making construction and
deconstruction syntactically distinct... kind of finessing one of the
difficulties of the implementation of existential types. (Note that this
scheme extends quite naturally to multi-parameter type classes... the
constructor and deconstructor just need one one parameter for each type class
parameter and one for the *_object value. Actually, this would be much
nicer using a function, but first things first.)

I have implemented a generator like the one I just described; it turned
out to be quite simple (although there are still quite a few holes). It
takes as command line arguments the name ane arity of a type class, and
generates (on stdout at the moment) a module which implement a type for it.

There are several obvious deficiencies of the generator at the moment:
	- The type_layouts and type_functors are not right. This needs
	  thought
	- The unification, compare and index preds just abort if called. It
	  should not be too difficult to generate code which checks that the
	  values are of the same type, then forwards to the specific special
	  pred for that type
	- The code is not too well documented
	- Functions would probably be nicer than predicates as constructors
	  and deconstructors.
	- The name of the module generated is just a simple mangling of the
	  typeclass name, as is the name of the module in which the generated
	  code expects to find the typeclass declaration.
	- The code it generates for multiparameter type classes triggers a
	  bug in the compiler. (Although it works on some simple examples
	  with single parameter type classes).

Anyhow, as an example, with the typeclass:

==============================================================================

:- module s.

:- interface.

:- typeclass s(X) where [
	pred p(X, int),
	mode p(in, out) is det
].

==============================================================================

We can run the generator program (called mk_tc_object for the moment) thus:

% ./mk_tc_object s 1 > s_object.m

The contents of s_object.m ends up as:

==============================================================================

:- module s_object.

:- interface.

:- type s_object.

:- import_module s.

:- pred construct_s_object(T1, s_object) <= s(T1).
:- mode construct_s_object(in, uo) is det.

:- some [T1] (pred deconstruct_s_object(T1, s_object) & s(T1)).
:- mode deconstruct_s_object(out, in) is det.

:- implementation.

:- pragma c_code(will_not_call_mercury, construct_s_object(X1::in, Output::uo), "
	incr_hp(Output, 2);
	field(mktag(0), Output, 0) = (Word) TypeInfo_for_T1;
	field(mktag(0), Output, 1) = (Word) X1;
").

:- pragma c_code(will_not_call_mercury, deconstruct_s_object(X1::out, Input::in), "
	TypeInfo_for_T1 = field(mktag(0), Input, 0);
	X1 = 	field(mktag(0), Input, 1);
").

:- pragma c_code("

Define_extern_entry(mercury____Unify___s_object__s_object_0_0);
Define_extern_entry(mercury____Index___s_object__s_object_0_0);
Define_extern_entry(mercury____Compare___s_object__s_object_0_0);

MR_MAKE_STACK_LAYOUT_ENTRY(mercury____Unify___s_object__s_object_0_0);
MR_MAKE_STACK_LAYOUT_ENTRY(mercury____Compare___s_object__s_object_0_0);
MR_MAKE_STACK_LAYOUT_ENTRY(mercury____Index___s_object__s_object_0_0);
BEGIN_MODULE(unify_s_object_module)
	init_entry_sl(mercury____Unify___s_object__s_object_0_0);
	init_entry_sl(mercury____Compare___s_object__s_object_0_0);
	init_entry_sl(mercury____Index___s_object__s_object_0_0);
BEGIN_CODE
Define_entry(mercury____Unify___s_object__s_object_0_0);
{
	fatal_error(""typeclass unification not implemented"");
}
Define_entry(mercury____Compare___s_object__s_object_0_0);
{
	fatal_error(""typeclass comparison not implemented"");
}
Define_entry(mercury____Index___s_object__s_object_0_0);
{
	fatal_error(""typeclass indexing not implemented"");
}
END_MODULE
/* Ensure that the initialization code for the above module gets run.
*/
/*
 * INIT sys_init_unify_s_object_module
 * */
extern ModuleFunc unify_s_object_module;
void sys_init_unify_s_object_module(void); /* suppress gcc -Wmissing-decl warning */
void sys_init_unify_s_object_module(void) {
	unify_s_object_module();
}

#ifdef  USE_TYPE_LAYOUT

const struct mercury_data_s_object__base_type_layout_s_object_0_struct {
	TYPE_LAYOUT_FIELDS} mercury_data_s_object__base_type_layout_s_object_0 = {
	make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG,
		mkbody(TYPELAYOUT_UNIV_VALUE))
};
const struct mercury_data_s_object__base_type_functors_s_object_0_struct {	Integer f1;} mercury_data_s_object__base_type_functors_s_object_0 = {
	MR_TYPEFUNCTORS_UNIV
};

#endif
").

==============================================================================

This an be used by something like:

==============================================================================

:- module s_test.

:- interface.

:- import_module io.

:- pred main(io__state::di, io__state::uo) is det.

:- implementation.

:- import_module s, s_object.

:- import_module int, string, list.

:- instance s(int) where [
	pred(p/2) is p_int
].

:- pred p_int(int::in, int::out) is det.

p_int(X, X).

:- instance s(string) where [
	pred(p/2) is p_string
].

:- pred p_string(string::in, int::out) is det.

p_string(X,  Z) :-
	string__length(X, Z).

main -->
	{ construct_s_object(3, X) },
	{ construct_s_object("hello world", Y) },
		% Z contains things of different types, but which all
		% belong to typeclass "s".
	{ Z = [X,Y] },
	{ list__map(
		lambda([A0::in, B::out] is det, 
		(
			deconstruct_s_object(A, A0),
			p(A, B)
		)),
		Z, Answers) 
	},
	io__write_list(Answers, "\n", io__write_int),
	io__write_string("\n").

==============================================================================

This produces the output:
% ./s_test
3
11

Comments? Perhaps I should put this in the extras directory?

For those who are interested, the code for the generator follows:

==============================================================================

% This program take the name and arity of a typeclass as command line
% arguments and produces on stdout a module which declares and implements
% a type which stores (sequences of!) values which belong to that type class.
%
% In a sense, this generalises the "univ" type. "univ" holds values of any
% type... those in the "univ" type class if you like.
:- module mk_tc_object.

:- interface.

:- import_module io.

:- pred main(io__state::di, io__state::uo) is det.

:- implementation.

:- import_module list, string, int.

main -->
	io__command_line_arguments(Argv),
	(
		{ Argv = [Name, CountString] },
		{ string__to_int(CountString, Count) }
	->
		generate(Name, Count)
	;
		usage
	).

:- pred usage(io__state::di, io__state::uo) is det.

usage  --> io__write_string("usage: mk_tc_object typeclass_name arity\n").

:- pred generate(string::in, int::in, io__state::di, io__state::uo) is det.

generate(Name, Count) -->
	generate_interface(Name, Count),
	generate_implementation(Name, Count),
	generate_unification_preds(Name, Count).

:- pred generate_interface(string::in, int::in, 
	io__state::di, io__state::uo) is det.

generate_interface(Name, Count) -->
	io__write_string(":- module "),
	io__write_string(Name),
	io__write_string("_object.\n\n"),
	io__write_string(":- interface.\n\n"),

		% The type decl
	io__write_string(":- type "),
	io__write_string(Name),
	io__write_string("_object.\n\n"),

		% Import the typeclass definition.
		% XXX the name of this module should just
		% XXX be a command line parameter.
	io__write_string(":- import_module "),
	io__write_string(Name),
	io__write_string(".\n\n"),

		% The construction pred
	io__write_string(":- pred construct_"),
	io__write_string(Name),
	io__write_string("_object("),
	{ WriteVars = 
		lambda([N::in, IO0::di, IO::uo] is det,
		(
			io__write_char('T', IO0, IO1),
			io__write_int(N, IO1, IO)
		))
	},
	commasep1(Count, WriteVars),
	io__write_string(Name),
	io__write_string("_object) <= "),
	io__write_string(Name),
	io__write_char('('),
	commasep(Count, WriteVars),
	io__write_string(").\n"),

	io__write_string(":- mode construct_"),
	io__write_string(Name),
	io__write_string("_object("),
	for(Count, ignore1(io__write_string("in, "))),
	io__write_string("uo) is det.\n\n"),


		% The deconstruction pred
	io__write_string(":- some ["),
	commasep(Count, WriteVars),
	io__write_string("] (pred deconstruct_"),
	io__write_string(Name),
	io__write_string("_object("),
	commasep1(Count, WriteVars),
	io__write_string(Name),
	io__write_string("_object) & "),
	io__write_string(Name),
	io__write_char('('),
	commasep(Count, WriteVars),
	io__write_string(")).\n"),

	io__write_string(":- mode deconstruct_"),
	io__write_string(Name),
	io__write_string("_object("),
	for(Count, ignore1(io__write_string("out, "))),
	io__write_string("in) is det.\n\n").

:- pred generate_implementation(string::in, int::in, 
	io__state::di, io__state::uo) is det.

generate_implementation(Name, Count) -->
	io__write_string(":- implementation.\n\n"),

		% The construction pred
	io__write_string(
		":- pragma c_code(will_not_call_mercury, construct_"),
	io__write_string(Name),
	io__write_string("_object("),
	{ WriteInVars = 
		lambda([N::in, IO0::di, IO::uo] is det,
		(
			io__write_char('X', IO0, IO1),
			io__write_int(N, IO1, IO2),
			io__write_string("::in", IO2, IO)
		))
	},
	commasep1(Count, WriteInVars),
	io__write_string("Output::uo), ""\n"),
	io__write_string("\tincr_hp(Output, "),
	io__write_int(Count+1),
	io__write_string(");\n"),
	io__write_string(
		"\tfield(mktag(0), Output, 0) = (Word) TypeInfo_for_T1;\n"),
	{ WriteInitialisers = 
		lambda([VarNum::in, IO0::di, IO::uo] is det,
		(
			io__write_string(
				"\tfield(mktag(0), Output, ", IO0, IO1),
			io__write_int(VarNum, IO1, IO2),
			io__write_string(") = (Word) ", IO2, IO3),
			io__write_char('X', IO3, IO4),
			io__write_int(VarNum, IO4, IO5),
			io__write_string(";\n", IO5, IO)
		))
	},
	for(Count, WriteInitialisers),
	io__write_string(""").\n\n"),


		% The deconstruction pred
	io__write_string(
		":- pragma c_code(will_not_call_mercury, deconstruct_"),
	io__write_string(Name),
	io__write_string("_object("),
	{ WriteOutVars = 
		lambda([N::in, IO0::di, IO::uo] is det,
		(
			io__write_char('X', IO0, IO1),
			io__write_int(N, IO1, IO2),
			io__write_string("::out", IO2, IO)
		))
	},
	commasep1(Count, WriteOutVars),
	io__write_string("Input::in), ""\n"),
	io__write_string("\tTypeInfo_for_T1 = field(mktag(0), Input, 0);\n"),
	{ WriteExtractor = 
		lambda([TheVarNum::in, IO0::di, IO::uo] is det,
		(
			io__write_string("\tX", IO0, IO1),
			io__write_int(TheVarNum, IO1, IO2),
			io__write_string(" = ", IO2, IO3),
			io__write_string(
				"\tfield(mktag(0), Input, ", IO3, IO4),
			io__write_int(TheVarNum, IO4, IO5),
			io__write_string(");\n", IO5, IO)
		))
	},
	for(Count, WriteExtractor),
	io__write_string(""").\n\n").

:- pred generate_unification_preds(string::in, int::in, 
	io__state::di, io__state::uo) is det.

generate_unification_preds(Name0, _Count) -->
	{ string__append(Name0, "_object", Name) },
	{ unify_name(Name, Unify) },
	{ index_name(Name, Index) },
	{ compare_name(Name, Compare) },

	io__write_strings([
		":- pragma c_code(""\n\n",

		"Define_extern_entry(",
		Unify,
		");\n",

		"Define_extern_entry(",
		Index,
		");\n",

		"Define_extern_entry(",
		Compare,
		");\n",

		"\n",

		"MR_MAKE_STACK_LAYOUT_ENTRY(",
		Unify,
		");\n",

		"MR_MAKE_STACK_LAYOUT_ENTRY(",
		Compare,
		");\n",

		"MR_MAKE_STACK_LAYOUT_ENTRY(",
		Index,
		");\n",


		"BEGIN_MODULE(unify_",
		Name,
		"_module)\n",

		"\tinit_entry_sl(",
		Unify,
		");\n",

		"\tinit_entry_sl(",
		Compare,
		");\n",

		"\tinit_entry_sl(",
		Index,
		");\n",

		"BEGIN_CODE\n",

		"Define_entry(",
		Unify,
		");\n{\n",
		"\tfatal_error(""""typeclass unification ",
		"not implemented"""");\n",
		"}\n",

		"Define_entry(",
		Compare,
		");\n{\n",
		"\tfatal_error(""""typeclass comparison ",
		"not implemented"""");\n",
		"}\n",

		"Define_entry(",
		Index,
		");\n{\n",
		"\tfatal_error(""""typeclass indexing ",
		"not implemented"""");\n",
		"}\n",

		"END_MODULE\n",

		"/* Ensure that the initialization code for the above module ",
		"gets run.\n*/\n",
		"/*\n",
		" * INIT sys_init_unify_",
		Name,
		"_module\n",
		" * */\n",

		"extern ModuleFunc unify_",
		Name,
		"_module;\n",
		"void sys_init_unify_",
		Name,
		"_module(void); /* suppress gcc -Wmissing-decl warning */\n",
		"void sys_init_unify_",
		Name,
		"_module(void) {\n",
		"\tunify_",
		Name,
		"_module();\n",
		"}\n\n",

		"#ifdef  USE_TYPE_LAYOUT\n\n",

			% XXX This is a lie
		"const struct mercury_data_",
		Name,
		"__base_type_layout_",
		Name,
		"_0_struct {\n",
		"\tTYPE_LAYOUT_FIELDS",
		"} mercury_data_",
		Name,
		"__base_type_layout_",
		Name,
		"_0 = {\n",
        	"\tmake_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG,\n",
                "\t\tmkbody(TYPELAYOUT_UNIV_VALUE))\n",
		"};\n",

			% XXX This too
		"const struct mercury_data_",
		Name,
		"__base_type_functors_",
		Name,
		"_0_struct {",
        	"\tInteger f1;",
		"} mercury_data_",
		Name,
		"__base_type_functors_",
		Name,
		"_0 = {\n",
        	"\tMR_TYPEFUNCTORS_UNIV\n",
		"};\n\n",

		"#endif\n",

		""").\n"
	]).

:- pred unify_name(string::in, string::out) is det.
unify_name(Name, U) :-
	entry_name(Name, "Unify", U).

:- pred index_name(string::in, string::out) is det.
index_name(Name, I) :-
	entry_name(Name, "Index", I).

:- pred compare_name(string::in, string::out) is det.
compare_name(Name, C) :-
	entry_name(Name, "Compare", C).

:- pred entry_name(string::in, string::in, string::out) is det.
entry_name(Name, Entry, Result) :-
	string__append_list(
		["mercury____", Entry, "___", Name, "__", Name, "_0_0"],
		Result).


%--------------------------------------------------------------------------%

	% Given a pred with two args, produce a pred with three args which
	% ignores its first
:- func ignore1(pred(T1, T1)) = pred(T2, T1, T1).
:- mode ignore1(pred(di, uo) is det) = out(pred(in, di, uo) is det) is det.

ignore1(P) = lambda([_X::in, IO0::di, IO::uo] is det, P(IO0, IO)).

	% commasep is just like "for" applied to io operations, except that
	% it prints a comma between each iteration.
:- pred commasep(int, pred(int, io__state, io__state), io__state, io__state).
:- mode commasep(in, pred(in, di, uo) is det, di, uo) is det.

commasep(N, P) -->
	for(N, lambda([Number::in, IO0::di, IO::uo] is det,
		(
			P(Number, IO0, IO1),
			(
				Number > 1
			->
				io__write_string(", ", IO1, IO)
			;
				IO = IO1
			)
		))
	).

	% As above, but put a comma at the end too.
:- pred commasep1(int, pred(int, io__state, io__state), io__state, io__state).
:- mode commasep1(in, pred(in, di, uo) is det, di, uo) is det.
commasep1(N, P) -->
	commasep(N, P),
	io__write_string(", ").

	% A "for" loop
:- pred for(int, pred(int, T, T), T, T).
:- mode for(in, pred(in, in, out) is det, in, out) is det.
:- mode for(in, pred(in, di, uo) is det, di, uo) is det.

for(N0, P) -->
	(
		{ N0 > 0}
	->
		P(N0),
		{ N is N0 - 1 },
		for(N, P)
	;
		[]
	).

==============================================================================


dgj
-- 
David Jeffery (dgj at cs.mu.oz.au) |  Marge: Did you just call everyone "chicken"?
PhD student,                    |  Homer: Noooo.  I swear on this Bible!
Department of Computer Science  |  Marge: That's not a Bible; that's a book of
University of Melbourne         |         carpet samples!
Australia                       |  Homer: Ooooh... Fuzzy.