[mercury-users] Re: Handy Programming tool for Mercury.

[Ralph Becket]

True to form, I forgot to attach the file...  here it is.

Ralph

-- 
Ralph Becket  |  rwab1 at cam.sri.com  |  http://www.cam.sri.com/people/becket.html
-------------- next part --------------
#! /usr/local/bin/gawk -f

# ------------------------------------------------------------------------------
# state2m	Mon May 10 BST 1999	Ralph Becket <rwab1 at cl.cam.ac.uk>
# ------------------------------------------------------------------------------
#
# Tool to help automate the construction of `state containers' in
# Mercury.
#
# This program preprocesses a file as follows.  Any lines that do not
# start with a `*' are passed straight through.  Lines that start with
# a `*' must obey the grammar below.
#
# A type is declared to the preprocessor with
# 	* type type_name[(.*)] [different_constructor_name]
# followed by zero or more lines of
# 	*  field_name field_type fieldproperty* [% comment]
# where fieldproperty abbreviates [readonly | mutable | private | func]
# followed by a blank line.
#
# Code is generated with the following:
# 	* typespec type_name
# 	* predspec type_name
# 	* implementation type_name
#
# By default a field is taken to be RW, accessed and updated via
# predicates of spec
# 	:- pred field_name(type_name::in, field_type::out) is det.
# 	:- pred set_field_name(type_name::in,field_type::in,field_type::out)
# 			is det.
# respectively.
#
# If a field has property mutable, but not func, then it also has a
# predicate of spec
# 	:- pred chg_field_name(type_name::in,
# 			(pred(field_type::in, field_type::out) is det)::in,
# 			type_name::out) is det.
#
# If a field has property mutable and also func, then it also has a
# function of spec
# 	:- func chg_field_name(type_name, func(field_type) = field_type) =
# 			type_name.
#
# If a field has property readonly then the set_field_name predicate is not
# generated (nor is the chg_field_name predicate if the field is
# mutable).
#
# If a field has property func then the above predicates are instead
# implemented with functions with spec
# 	:- func field_name(type_name) = field_type.
# 	:- func set_field_name(type_name, field_type) = type_name.
#
# If a field has property private then it will not be declared in the
# predinterface section, but rather the implementation section.
#
# ------------------------------------------------------------------------------

$1 != "*" { print $0; in_type_spec = 0; next }

{ print "% "$0 }

$2 == "type" {

	if(NF < 3 || 4 < NF) {
		warn("syntax error: expected\n* type type_name[(.*)] [differentconstructor_name]\n              found\n"$0)
		exit 1
	}

	type_decl_name = $3
	type_name = $3
	sub("\\(.*", "", type_name)

	constructor_name = ( NF == 4 ? $4 : type_name )

	if(type_name in type_names) {
		warn("name error: type name used twice: "type_name)
		exit 1
	}

	ntype = ntypes++

# print ntype, type_name, type_decl_name, constructor_name

	type_names[ntype] = type_name
	type_decl_names[ntype] = type_decl_name
	constructor_names[ntype] = constructor_name

	in_type_spec = 1

	next
}

in_type_spec {

	comment = $0
	sub("^[^%]*", "", comment)
	sub("%.*", "", $0)

	if(NF < 3) {
		warn("syntax error: expected\n* field_name field_type fieldproperty* [% comment]\n found\n"$0 comment)
		exit 1
	}

	field_name = $2
	field_type = $3

	if((type_name,field_name) in field_names) {
		warn("name error: field name used twice in same type: "field_name)
		exit 1
	}
	field_names[type_name,field_name]

	nfield = nfields[ntype]++

# print ntype, type_name, nfield, field_name, field_type

	field_names[ntype,nfield] = field_name
	field_types[ntype,nfield] = field_type

	for(i = 4; i <= NF; i++) {
		if($i == "readonly") {
			is_readonly[ntype,nfield] = 1
		}
		else if($i == "mutable") {
			is_mutable[ntype,nfield] = 1
		}
		else if($i == "func") {
			is_function[ntype,nfield] = 1
		}
		else if($i == "private") {
			is_private[ntype,nfield] = 1
		}
		else {
			warn("syntax error: field property must be one of readonly, mutable, private, or func\n              found: "$i)
			exit 1
		}
	}

	next
}

$2 == "typespec" {

	if(NF != 3) {
		warn("syntax error: expected\n* typespec type_name\n              found\n"$0)
		exit 1
	}
	type_name = $3

	for(i = 0; i < ntypes; i++) {
		if(type_names[i] == type_name) {
			ntype = i
			break
		}
	}
	if(i == ntypes) {
		warn("name error: unrecognised type name: "type_name)
		exit 1
	}

# print ntype, type_name, nfields[ntype], type_decl_names[ntype]

	print ""
	if(nfields[ntype] == 0) {
		print ":- type "type_decl_names[ntype]" ---> "constructor_names[ntype]"."
	}
	else {
		print ":- type "type_decl_names[ntype]" ---> \n\t"constructor_names[ntype]"("
		for(i = 0; i < nfields[ntype]; i++) {
			print "\t\t"field_types[ntype,i] \
				( i + 1 == nfields[ntype] ? "" : "," )
		}
		print "\t)."
	}

	next
}

$2 == "predspec" {

	if(NF != 3) {
		warn("syntax error: expected\n* predspec type_name\n              found\n"$0)
		exit 1
	}
	type_name = $3

	for(i = 0; i < ntypes; i++) {
		if(type_names[i] == type_name) {
			ntype = i
			break
		}
	}
	if(i == ntypes) {
		warn("name error: unrecognised type name: "type_name)
		exit 1
	}

	print ""
	for(i = 0; i < nfields[ntype]; i++) {
		if(! is_private[ntype,i]) {
			print public_spec(ntype, i)
		}
	}

	next
}

$2 == "implementation" {

	if(NF != 3) {
		warn("syntax error: expected\n* implementation type_name\n              found\n"$0)
		exit 1
	}
	type_name = $3

	for(i = 0; i < ntypes; i++) {
		if(type_names[i] == type_name) {
			ntype = i
			break
		}
	}
	if(i == ntypes) {
		warn("name error: unrecognised type name: "type_name)
		exit 1
	}

	print ""
	for(i = 0; i < nfields[ntype]; i++) {
		print implementation(ntype, i)
	}

	next
}

{
	warn("syntax error: unrecognised syntax\n                  found\n"$0)
	exit 1
}

function public_spec(ntype, nfield,    s, tf) {

	tf = ntype SUBSEP nfield

	s = ""

	if(! is_private[tf]) {
		s = s get_spec(ntype, nfield)
		if(! is_readonly[tf]) {
		s = s set_spec(ntype, nfield)
		}
		if(is_mutable[tf]) {
			s = s mut_spec(ntype, nfield)
		}
	}
	
	return s
}

function private_spec(ntype, nfield,    s, tf) {

	tf = ntype SUBSEP nfield

	s = ""

	if(is_private[tf]) {
		s = s "\n"get_spec(ntype, nfield)
		s = s set_spec(ntype, nfield)
		if(is_mutable[tf]) {
			s = s mut_spec(ntype, nfield)
		}
	}
	else if(is_readonly[tf]) {
		s = s set_spec(ntype, nfield)
	}

	return s
}

function get_spec(ntype, nfield,    s, tf, isfn) {

	tf = ntype SUBSEP nfield
	isfn = is_function[tf]

	s = ":- "( isfn ? "func " : "pred ")field_names[tf]"("
	s = s type_decl_names[ntype]
	s = s ( isfn ? ") = "field_types[tf]".\n" : ", "field_types[tf]").\n" )
	s = s ( isfn ? "" : ":- mode "field_names[tf]"(in, out) is det.\n" )

	return s
}

function set_spec(ntype, nfield,    s, tf, isfn) {

	tf = ntype SUBSEP nfield
	isfn = is_function[tf]

	s = ":- "( isfn ? "func " : "pred ")"set_"field_names[tf]"("
	s = s type_decl_names[ntype]", "field_types[tf]
	s = s ( isfn ? ") = "type_decl_names[ntype]".\n" : ", "type_decl_names[ntype]").\n" )
	s = s ( isfn ? "" : ":- mode set_"field_names[tf]"(in, in, out) is det.\n" )

	return s
}

function mut_spec(ntype, nfield,    s, tf, isfn, pt, pm) {

	tf = ntype SUBSEP nfield
	isfn = is_function[tf]
	if(isfn) {
		pt = "func("field_types[tf]") = "field_types[tf]
		pm = ""
	}
	else {
		pt = "pred("field_types[tf]", "field_types[tf]")"
		pm = "pred(in, out) is det"
	}

	s = ":- "( isfn ? "func " : "pred ")"chg_"field_names[tf]"("
	s = s type_decl_names[ntype]", "pt
	s = s ( isfn ? ") = "type_decl_names[ntype]".\n" : ", "type_decl_names[ntype]").\n" )
	s = s ( isfn ? "" : ":- mode chg_"field_names[tf]"(in, "pm", out) is det.\n" )

	return s
}

function implementation(ntype, nfield,    s, tf, ismut) {

	tf = ntype SUBSEP nfield
	ismut = is_mutable[tf]

	s = private_spec(ntype, nfield)"\n"
	s = s get_implementation(ntype, nfield)"\n\n"
	s = s set_implementation(ntype, nfield)"\n"
	if(ismut) {
		s = s "\n"mut_implementation(ntype, nfield)"\n"
	}

	return s
}

function get_implementation(ntype, nfield,    s, tf, isfn) {

	tf = ntype SUBSEP nfield
	isfn = is_function[tf]

	s = field_names[tf]"("select_nth_arg(ntype, nfield, "X")
	s = s ( isfn ? ") = X." : ", X)." )

	return s
}

function set_implementation(ntype, nfield,    s, r, tf, isfn) {

	tf = ntype SUBSEP nfield
	isfn = is_function[tf]
	r = replace_nth_arg(ntype, nfield, "X")

	s = "set_"field_names[tf]"("select_but_nth_arg(ntype, nfield)", X"
	s = s ( isfn ? ") = "r"." : ", "r")." )

	return s
}

function mut_implementation(ntype, nfield,    s, r, tf, isfn) {

	tf = ntype SUBSEP nfield
	isfn = is_function[tf]
	replace_nth_arg(ntype, nfield, "Y")

	s = "chg_"field_names[tf]"("replace_nth_arg(ntype, nfield, "X")", F"

	if(isfn) {
		s = s ") = "replace_nth_arg(ntype, nfield, "F(X)")"."
	}
	else {
		s = s ", "replace_nth_arg(ntype, nfield, "Y")") :-\n"
		s = s "\tF(X, Y)."
	}

	return s
}

function select_nth_arg(ntype, nfield, arg,    s, i) {

	for(i = 0; i < nfields[ntype]; i++) {
		s = s ( i == nfield ? arg : "_" )
		s = s ( i+1 < nfields[ntype] ? ", " : "" )
	}

	return type_names[ntype]"("s")"
}

function select_but_nth_arg(ntype, nfield, arg,    s, i) {

	for(i = 0; i < nfields[ntype]; i++) {
		s = s ( i == nfield ? "_" : "X"i )
		s = s ( i+1 < nfields[ntype] ? ", " : "" )
	}

	return type_names[ntype]"("s")"
}

function replace_nth_arg(ntype, nfield, arg,    s, i) {

	for(i = 0; i < nfields[ntype]; i++) {
		s = s ( i == nfield ? arg : "X"i )
		s = s ( i+1 < nfields[ntype] ? ", " : "" )
	}

	return type_names[ntype]"("s")"
}

function warn(s) {

	print FILENAME":"FNR":"s > "/dev/stderr"
}