#######################################
#
#  C-like Macro system for Tcl.
#
#    cmacro::reset ?beginChar? ?midChar? ?endChar?
#
#	Delete any existing macro definitions,
#	and set the special substitution delimiters.
#	Defaults are  "<" "," ">"
#
#    cmacro::define name formal_parameter_list body
#
#	Define a macro named "name" to expand to "body",
#	substituting occurrances of the formal parameters
#	with values provided when the macro is used.
#	Tcl "string map" is used to make the substitutions.
#
#    cmacro::substitute string
#
#	Preform macro substitutions on string
#	and return the new string.
#
#    cmacro::mproc name params body
#
#	Define a procedure just like "proc" does,
#	but first preform macro substitutions on the body.
#
#  For examples, see the tests at the end of this file.
#  To test, run with ::argv set to "--test-cmacro"
#
###################################


# Copyright 2005-2006 Henry Strickland   # @yak.net : <strick> #
#
# This software is copyrighted by Henry Strickland.
# 
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
# 
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
# 
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.


namespace eval cmacro {

	variable BeginChar "<"
	variable MidChar   ","
	variable EndChar   ">"
	variable Defines
	variable Alternation
	variable Regexp

	# reset:  Clear any macro definitions, and set special chars for future macro substitution.
	proc reset {{beginChar "<"} {midChar ","} {endChar ">"}} {
		variable BeginChar 
		variable MidChar   
		variable EndChar   
		variable Defines
		variable Alternation
		variable Regexp

		set BeginChar $beginChar
		set MidChar $midChar
		set EndChar $endChar

		if {[info exists Defines]} { unset Defines }
		if {[info exists Alternation]} { unset Alternation }
		if {[info exists Regexp]} { unset Regexp }
	}

	# define:  Define a macro
	proc define {mname margs mbody} {
		variable BeginChar 
		variable MidChar   
		variable EndChar   
		variable Defines
		variable Alternation
		variable Regexp

		set Defines($mname) [list $margs $mbody]

		regsub -all . $mname {[&]} escaped_mname

		if [info exists Alternation] {
			append Alternation "|$escaped_mname"
		} else {
			set Alternation "$escaped_mname"
		}

		set Regexp "^(.*)\\m($Alternation)\[$BeginChar\](\[^$BeginChar$EndChar\]*)\[$EndChar\](.*)\$"
	}

	# mproc:  Define a proc, substituting any macros used in the body.
	proc mproc {pname pargs pbody} {
		variable BeginChar 
		variable MidChar   
		variable EndChar   
		variable Defines
		variable Alternation
		variable Regexp

		if [info exists Alternation] {
			uplevel 1 [list proc $pname $pargs [substitute $pbody]]
		} else {
			uplevel 1 [list proc $pname $pargs $pbody]
		}
	}

	# substitute:  Substitute all macros in a string.
	proc substitute s {
		variable BeginChar 
		variable MidChar   
		variable EndChar   
		variable Defines
		variable Alternation
		variable Regexp

		set i 0

#puts "RE=`$Regexp'"

		while {[regexp $Regexp $s - pre mname mguts post]} {
			if {[incr i]>999} { error "too many substitutions -- infinite recursion?" }

			set margs [lindex $Defines($mname) 0]
			set mbody [lindex $Defines($mname) 1]

#puts "pre=`$pre'    mname=`$mname'    mguts=`$mguts'    post=`$post'    margs=`$margs'    mbody=`$mbody'"

			foreach k $margs v [split $mguts $MidChar] {
				set mbody [string map [list $k [string trim $v]] $mbody]
#puts "...k=`$k'  v=`$v'   mbody=`$mbody'"
			}
			set s "$pre$mbody$post"
#puts "...s=`$s'"
		}
		set s
	}

	namespace export {[a-z]*}
}

if { $::argv eq "--test-cmacro" } {

	set ::CountSuccesses 0
	proc AssertEq {expected command} {
		set value [uplevel 1 $command]
		if { $expected ne $value } { error "Expected `$expected' Got `$value' For `$command'" }
		incr ::CountSuccesses
	}

	# Test with parentheses for special chars
			
	cmacro::reset ( , )
	cmacro::define hd X {[lindex X 0]}
	cmacro::define tl X {[lrange X 1 end]}
	cmacro::define tlN {N X} {[lrange X N end]}

	cmacro::mproc second list { return hd( tl($list) ) }
	cmacro::mproc tailN {n list} { return tlN($n, $list) }

	AssertEq {monkey [lindex $abc 0] banana [lrange $abc 1 end] rock}  {
				cmacro::substitute {monkey hd($abc) banana tl($abc) rock}  }
	AssertEq 1492		{ second    {1066 1492 1776 2001} }
	AssertEq {1776 2001}	{ tailN  2 {1066 1492 1776 2001 } }


	###############################################################

 	# test with ticks & tocks

	cmacro::reset ` , '
	cmacro::define hd X {[lindex X 0]}
	cmacro::define tl X {[lrange X 1 end]}
	cmacro::define tlN {N X} {[lrange X N end]}

	cmacro::mproc second list { return hd` tl`$list' ' }
	cmacro::mproc tailN {n list} { return tlN`$n, $list' }

	AssertEq {monkey [lindex $abc 0] banana [lrange $abc 1 end] rock}  {
				cmacro::substitute {monkey hd`$abc' banana tl`$abc' rock}  }
	AssertEq 1492		{ second    {1066 1492 1776 2001} }
	AssertEq {1776 2001}	{ tailN  2 {1066 1492 1776 2001 } }

	###############################################################

	# test with colon-pipe-semicolon delimiters

	cmacro::reset ":" "|" ";"
	cmacro::define hd X {[lindex X 0]}
	cmacro::define tl X {[lrange X 1 end]}
	cmacro::define tlN {N X} {[lrange X N end]}

	cmacro::mproc second list { return hd: tl:$list; ; }
	cmacro::mproc tailN {n list} { return tlN:$n| $list; }

	AssertEq {monkey [lindex $abc 0] banana [lrange $abc 1 end] rock}  {
				cmacro::substitute {monkey hd:$abc; banana tl:$abc; rock}  }
	AssertEq 1492		{ second    {1066 1492 1776 2001} }
	AssertEq {1776 2001}	{ tailN  2 {1066 1492 1776 2001 } }

	###############################################################

	# test with default angle-brackets

	cmacro::reset
	cmacro::define hd X {[lindex X 0]}
	cmacro::define tl X {[lrange X 1 end]}
	cmacro::define tlN {N X} {[lrange X N end]}


	cmacro::mproc second list { return hd< tl<$list> > }
	cmacro::mproc tailN {n list} { return tlN<$n, $list> }

	AssertEq {monkey [lindex $abc 0] banana [lrange $abc 1 end] rock}  {
				cmacro::substitute {monkey hd<$abc> banana tl<$abc> rock}  }
	AssertEq 1492		{ second    {1066 1492 1776 2001} }
	AssertEq {1776 2001}	{ tailN  2 {1066 1492 1776 2001 } }


	###############################################################

	# test with guillemets and division symbol instead of comma

	cmacro::reset « ÷ »
	cmacro::define hd X {[lindex X 0]}
	cmacro::define tl X {[lrange X 1 end]}
	cmacro::define tlN {N X} {[lrange X N end]}


	cmacro::mproc second list { return hd« tl«$list» » }
	cmacro::mproc tailN {n list} { return tlN«$n ÷ $list» }

	AssertEq {monkey [lindex $abc 0] banana [lrange $abc 1 end] rock}  {
				cmacro::substitute {monkey hd«$abc» banana tl«$abc» rock}  }
	AssertEq 1492		{ second    {1066 1492 1776 2001} }
	AssertEq {1776 2001}	{ tailN  2 {1066 1492 1776 2001 } }

	puts stderr "$::argv0 OKAY.  $::CountSuccesses Tests Succeeded."

	###############################################################
	#
	# Small Benchmark

	set line "Rough winds do shake the darling buds of May"

	cmacro::reset
	proc NormalProc {s} { return "[lindex $s 0] [lrange $s 1 end]" }
	cmacro::mproc MacroProc {s} { return "hd(s) tl(s)" }

	puts stderr "Benchmark MacroProc: [set mpt [time {MacroProc $line} 10000]]"

	puts stderr "Benchmark NormalProc: [set npt [time {NormalProc $line} 10000]]"

	set mpt [lindex $mpt 0]
	set npt [lindex $npt 0]
	puts stderr "NormalProc took [expr { $npt / $mpt }] times as long as MacroProc"
}