Artifact 9deef7092bc84cf8272532be12b43716df493629:

• Executable file packages/proc/lib/proc.tcl — part of check-in [7f8a8ea012] at 2021-05-22 09:54:07 on branch trunk — update various things to reflect changes in other packages

  add new files and packages (user: pooryorick size: 29108)

#! /usr/bin/env tclsh


namespace eval doc {}

package require {ycl ns join}
interp alias {} [[yclprefix] ns join [
	namespace current] nsjoin] {} [[yclprefix] ns join [yclprefix] ns join]

package require {ycl ns absolute}
namespace import [nsjoin [yclprefix] ns absolute?]
namespace import [nsjoin [yclprefix] ns globalns]
package require {ycl ns normalize}
namespace import [nsjoin [yclprefix] ns normalize]

package require {ycl ns absolute}
interp alias {} [nsjoin [namespace current] absolute?] {} [
	yclprefix] ns absolute?


variable doc {
	description {
		A set of useful arguments to be copied into documentation for other
		procedures.

	}
	args {
		dry {
			description {
				If true, don't actually perform operations that modify storage
			}
			constrain {[string is boolean $dry]}
			default {lindex false}
			process {
				if {$dry} {
					proc [nsjoin $_ dry] args {}
				} else {
					proc [nsjoin $_ dry] args [
						list [nsjoin {} tailcall] {*}$args]
				}
			}
		}
	}
}


# out of alphabetic order because it is used below

variable [nsjoin doc stub] {
	description {
		create a procedure that first evaluates $pre only the first time it is called.
	}
}

variable apply_ [nsjoin {} apply]
variable dict_ [nsjoin {} dict]
variable error_ [nsjoin {} error]
variable expr_ [nsjoin {} expr]
variable foreach_ [nsjoin {} foreach]
variable info_ [nsjoin {} info]
variable interp_ [nsjoin {} interp]
variable list_ [nsjoin {} list]
variable proc_ [nsjoin {} proc]
variable set_ [nsjoin {} set]
variable switch_ [nsjoin {} switch]
variable tailcall_ [nsjoin {} tailcall]
variable try [nsjoin {} try]
variable uplevel_ [nsjoin {} uplevel]
variable upvar_ [nsjoin {} upvar]


proc stub {name argspec pre body} [string map [
	list @uplevel@ [list $uplevel_] \
		@proc@ [list $proc_] \
		@upvar@ [list $upvar_] \
		@list@ [list $list_] \
		@tailcall@ [list $tailcall_] \
		@try@ [list $try]
	] {

	variable apply_
	variable proc_
	variable uplevel_
	uplevel 1 [list $proc_ $name args [
		list $apply_ [list {name argspec pre body} {

			@uplevel@ 1 [@list@ @try@ $pre]
			@proc@ $name $argspec $body
			@upvar@ args args
			@tailcall@ @tailcall@ $name {*}$args
		} [uplevel 1 {namespace current}]] $name $argspec $pre $body]]
}]

variable [nsjoin doc alias] {
	description {
		creates an alias to a target command prefix

		if an alias should continue to refer to the new name of the target when
		the target is renamed
			then use [proc import]
				defined below
			instead
	}
}

proc alias {alias args} {
	package require {ycl ns ascall}
	if {![llength $args]} {
		lappend args $alias
		set alias [namespace tail $alias]
	}
	if {![absolute? $alias]} {
		set alias [nsjoin [uplevel 1 {namespace current}] $alias]
	}

	set name [lindex $args 0]

	if {![absolute? $name]} {
		set args [namespace eval [uplevel 1 {namespace current}] [
			list [yclprefix] ns ascall {*}$args[set args {}]]]
	}
	uplevel 1 [list [namespace which interp] alias {} $alias {} {*}$args]
}


alias [nsjoin [yclprefix] ns normalize]

alias apply_ [nsjoin {} apply]


proc aliases script {
	package require {ycl parse tcl commands}
	alias [nsjoin [yclprefix] parse tcl commands commands]
	foreach command [commands $script] {
		set length [llength $command]
		switch $length {
			1 {
				set package [lindex $command 0]
				set version {}
				if {[lindex $package 0] eq {ycl}} {
					set parts [lrange $package 1 end]
				} else {
					set parts $package
				}
				set alias [list [lindex $package end] [
					nsjoin [yclprefix] {*}$parts]]
			}
			2 {
				lassign $command[set command {}] package alias
				set version {}
			}
			default {
				set alias [lindex $comand end]
				set package [lindex $command 0]
				set version [lrange $command[set command {}] 1 end-1]
			}
		}
		uplevel 1 [list [namespace which package] require $package {*}$version]

		if {
			(
				[string is list $alias] && ![llength $alias]
			)
			||
			$alias eq {}
		} {
			set alias [list [nsjoin [yclprefix] {*}k]]
		}

		foreach command [commands $alias] {
			set length [llength $command]
			switch $length {
				1 {
					set command [lassign $command[set command {}] alias]
					if {[absolute? $alias]} {
						set target [list $alias]
						set alias [namespace tail $alias]
					} else {
						set target $alias
					}
				}
				default {
					set command [lassign $command[set command {}] alias target]
				}
			}

			if {![absolute? $target]} {
				if {[lindex $package 0] eq {ycl}} {
					set target [nsjoin [yclprefix] {*}[lrange $package 1 end] $target]
				} else {
					set target [nsjoin [yclprefix] {*}[$package] $target]
				}
			}
			
			uplevel 1 [list [namespace which alias] $alias $target {*}$command]
		}
	}
}


proc argsswitch switch {
	set length [llength $switch]
	if {$length % 2} {
		error [list {malformed switch}]
	}
	set switch [lassign $switch[set switch {}] first body]
	lappend res [namespace which if] $first $body
	foreach {expr body} $switch[set switch {}] {
		lappend res elseif $expr $body
	}
	lappend res else {
		error [list {wrong # args}]
	}
	return $res
}


variable [nsjoin doc import] {
	description
		like [namespace import] but the name of the new command may be
		specified

}
proc import args {
	if {[llength $args] == 2} {
		lassign $args alias target
	} elseif {[llength $args] == 1} {
		lassign $args target
		set alias [namespace tail $target]
	} else {
		error [list {wrong # args}]
	}
	set fulltarget [uplevel 1 [list [namespace which namespace] which $target]]
	if {$fulltarget eq {}} {
		return -code error [list {no such command} $target]
	}


	set needsimport 1
	if {[absolute? $alias]} {
		set fullalias $alias
	} else {
		set fullalias [nsjoin [uplevel 1 [
			list [namespace which namespace] current]] $alias]
		if {[namespace which $fullalias] ne {}} {
			set origin [namespace origin $fullalias]
			if {$origin eq $fulltarget} {
				set needsimport 0
			}
		}
	}

	if {$needsimport} {
		set qualifiers [namespace qualifiers $fulltarget]
		if {$qualifiers eq {}} {
			set qualifiers [globalns]
		}
		set save [namespace eval $qualifiers {
			namespace export}]

		namespace eval $qualifiers {namespace export *}
		while {[namespace exists [
			set tmpns [nsjoin [namespace current] [info cmdcount]]]]} {}
		set code [catch {set newcmd [namespace eval $tmpns [
			string map [list @{fulltarget} [list $fulltarget]] {
			namespace import @{fulltarget}
		}]]} cres copts]
		namespace eval $qualifiers [
			list namespace export -clear {*}$save]
		if {$code} {
			return -options $copts $cres
		}

		uplevel 1 [list [namespace which rename] [nsjoin $tmpns [
			namespace tail $target]] $fullalias]
		namespace delete $tmpns 
	}

	return [uplevel 1 [list [namespace which namespace] which $alias]]
}


proc imports {to from list} {
	foreach name $list {
		optswitch [llength $name] {
			1 {
				uplevel 1 [list [namespace which namespace] eval $to [
					list [namespace which import] [
						nsjoin $from [lindex $name 0]]]]
			}
			2 {
				uplevel 1 [list [namespace which namespace] eval $to [
					list [namespace which import] [lindex $name 0] [
						nsjoin $from [lindex $name 1]]]]
			}
		}
	}
}


variable [nsjoin doc argnames] {
	description {
		"argnames" returns the argument names of the procedure that calls it.
	}
}
proc argnames {} {
	variable apply_
	variable info_
	set cmd [uplevel 1 [list $info_ level 0]]

	set args [lassign $cmd rawname]
	set oldname $rawname

	# 2016-05-11: Gymnastics involving [apply], [tailcall] and namespace maps
	# can poke holes in the assumptions this code relies on . Use [uplevel
	# {namespace orgin} ...] instead .
	#if {![absolute? $name]} {
	#	#do [uplevel 2 ...] first in order to catch renamed imported commands.
	#	if {[set name [upcall 2 namespace which $oldname]] eq {}} {
	#		set name [upcall 1 namespace which $oldname]
	#	}
	#}

	# Maybe once
	# http://core.tcl.tk/tcl/tktview/229fa655638ab16d794ea819296cf9f3a9088619
	# is fixed, this can be reworked

	# uplevel 1 handles direct calls
	if {[catch {uplevel 1 [list namespace origin $rawname]} name]} {
		#uplevel 2 handles [rename] calls 
		set name [uplevel 2 [list namespace origin $rawname]]
	}

	if {$name eq {}} {
		error [list {no such command} $oldname]
	}
	if {$name eq $apply_} {
		set args [lindex $args 0 0]
	} else {
		set args [info args $name]
	}
	return $args
}


proc checkarg {level arg givenname argspecname neededname constrainedname} {
	variable expr_
	upvar $argspecname argspec $givenname given $neededname needed \
		$constrainedname constrained

	set seen [dict get $argspec seen]

	if {[dict exists $argspec count]} {
		set count [dict get $argspec count]
	} else {
		set count 1
	}

	if {$count == -1} {
		#no problem

		#{to do} {make negative numbers mean "at least"}
		dict unset needed $arg
	} else {
		if {$seen > $count} {
			return -level [expr {$level + 1}] -code error [
				list {too many occurrences} argument $arg allowed $count \
					occurrences $seen
			]
		} elseif {$seen == $count} {
			dict unset needed $arg
		}
	}

	if {[llength $given]} {
		set given [lassign $given[set given {}] val]
	} else {
		return -level [expr {$level + 1}] -code error [
			list {no value for argument} $arg]
	}

	if {[dict exists $argspec init] && $seen == 1} {
		uplevel $level [dict get $argspec init]
	}

	if {[dict exists $argspec constrain]} {
		lappend constrained $arg [dict get $argspec constrain]
	}


	if {[dict exists $argspec name]} {
		set varname [dict get $argspec name]
	} else {
		set varname $arg
	}
	upvar $level $varname var
	set var $val
	if {[dict exists $argspec validate]} {
		set validate [dict get $argspec validate]
		if {[regexp {[^[:space:]]} $validate]} {
			#validate is not empty
			set vres [uplevel $level [list $expr_ $validate]]
			if {!$vres} {
				return -level 2 -code error [
					list {failed validation} argument $arg \
						expression [concat $validate] value $val
				]
			}
		}
	}
	if {[dict exists $argspec process]} {
		set process [dict get $argspec process]
		upvar $level $varname var
		set var [uplevel $level $process]
	}
	if {[dict exists $argspec trigger]} {
		uplevel $level [dict get $argspec trigger]
	}
	return
}

variable [nsjoin doc checkargs] {
	description {
		check arguments passed to a function against the argument specification
		for that function .

		note that this documentation is "fake" in the sense that it isn't
		parsed by checkargs . We are not Münchhausen !
	}
	args {
		doc {
			description {
				The documentation for the the procedure; a dictionary that may
				contain keys as described here.
			}

			keys {
				description {
					a description of the operation of the command, in a
					natural language , e.g., Ket or English .
				}
				args {
					description {
						A dictionary in which the keys are the names of
						arguments that may be provided, by the same name, when
						calling the function .  Each key specifies an argument
						to the procedure , and is processed as specified in
						"keys" , below .

						Positional arguments and also the contents the
						procedure's $args argument , if one is present , are
						processed .
						
						The procedure's $args argument , is considered to be a
						varname-value dictionary which will be converted in
						variables in the scope of the procedure .
					}
					keys {
						description {
							description {
								A description of the argument .
							}
						}
						automatic {
							description {
								for use by {ycl shelf util configure }
							}
						}
						constrain {
							description {

								Evaluated as an expression .

								Used for inter-argument validation .

								Processed in the order they occur in the
								docspec after all inputs and defaults have been
								processed . Intended to check that processed
								input meets some criteria , as default values
								have already been set and input has been
								validated by this time .

							}
						}
						count {
							description {
								The number of times the argument may appear .

								-1 means unlimited

								#TODO: expand count to include a min and a max
							}
							default {
								set count 1
							}
							validate {
								[string is entier $count]
							}
						}
						init {
							description {
								A script to run for each argument in the
								argspec to make any needed initializations .
								All init scripts are run prior to walking
								through any actual arguments .
							}
							default {
								set init {}
							}
						}
						name {
							description {
								The name of the variable to assign the value to
								.  By default , the variable name is the same
								as the argument name .
							}
						}
						validate {
							description {
								evaluated as an expression

								processed as each argument is encountered.
								Intended primarily to check that input
								matches a certain pattern .

								For inter-argument validation, use "constrain"
							}
						}
						default {
							description {
								Indicates that this argument is optional 

								A script whose result becomes the value of this
								argument when it is not explicitly provided

								Processed after all inputs are processed, and
								in the order of occurrence in $doc .

								If this key is present , the argument is
								optional . Otherwise , it is mandatory.

								As a special case , if default is the empty
								string (as opposed to an expression whose
								result is the empty string) , the argument will
								not be set, and the validate step will be
								skipped, but the constrain step will still run
								. This allows for constraints that take into
								account the non-existence of the variable . For
								example , one might set a constraint to make
								sure that if the variable is not said , some
								other variable is .
							}
						}
						positional {
							description {
								if true
									the argument is positional

									if a positional argument is explicitly
									named in the procedure definition

										it isn't necessary to give it this
										value in the argument dictionary

								positional arguments not explicity named in the
								procedure definition are extracted from $args
								before $args is processed as a dictionary
							}
						}
						process {
							description {
								A script to invoke as the argument is
								encountered . Some potential uses :

									require that some other argument be
									specified first
								
								default arguments are "encountered" as
								described in their documentation

								Returns a value which replaces the value of
								\$arg

							}
						}
						trigger {
							description
								like "process"
									but the returned value is discarded
						}
					}
				}
				effects {
					description {
						A script that serves to check that intended effects
						of the command have actually occurrred . If it is
						empty , the command should be purely functional . If
						it doesn't exist at all , the command author simply
						hasn't specified it . Evaluation of effects can be
						enabled for debugging , or disabled for performance .
						The user semantics of the command the comand should
						not be modified by this script .

						TODO:  Implement this .
					}
				}
				extra {
					description {
						the name of an argument to assign each extra argument
						to

						validation and constraints are applied individually to
						each value
					}
				}
				stop {
					description {
						if an argument == $stop
							stop processing arguments

						if there is no $extra

							$stop is assigned to extra
					}
				}
				value {
					description {
						An expression that evaluated to determine whether
						the return value of the script is valid .

						Any additional non-code description of the value ,
						intended for humans , should go in teh "description"
						element .

						TODO: Implement this .
					}
				}
			}
		}
		given {
			description {
				the name of a variable containing the arguments given for a
				particular call of a function

				a dictionary
					thus
						for keys that occur more than once only the last
						occurance is used
			}
		}
	}
	value {
		A dictionary containing information about the following data

		keys {
			next {
				The index in $given of the next item that would have been
				checked had the function not stopped .
			}
		}
	}
}


proc checkargs {doc args} {
	variable expr_
	variable info_
	variable set_
	set given $args
	set constrained {}
	set positional [uplevel 1 [list [nsjoin [namespace current] argnames]]] 
	set mandatory [dict create]
	set res [dict create]
	set finalres {}
	if {[dict exists $doc stop]} {
		set stop [dict get $doc stop]
	}

	if {{args} eq [lindex $positional end]} {
		set positional [lrange $positional[set positional {}] 0 end-1]
	}

	set docargs [dict get $doc args]
	if 0 {
		to do
			pass the name of the variable containing the arg spec rather than
			the arg spec itself, so that this routine can validate it one time
			and then mark it as validated
	}
	set fakespec [dict create args $docargs] 
	validatespec fakespec
	set needed $docargs 
	set myns [namespace current]
	foreach arg $positional {
		set given [linsert $given[set given {}] 0 $arg [
			uplevel 1 [list $set_ $arg]]]
	}


	while {[llength $given]} {
		set given [lassign $given[set given {}] arg]

		#{to do} make Tcl compile this check away
		if {[info exists stop] && $arg eq $stop} {
			if {![dict exists $doc extra]} {
				dict set doc extra $stop
			}
			break
		}

		if {[dict exists $docargs $arg]} {
			dict update docargs $arg argspec {
				dict incr argspec seen
			}
			checkarg 2 $arg given argspec needed constrained
			continue
		}

		set found 0
		dict for {arg1 argspec} $needed {
			if {[dict exists $argspec positional]} {
				dict update docargs $arg1 argspec {
					dict incr argspec seen
				}
				set given [linsert $given[set given {}] 0 $arg]
				checkarg 2 $arg1 given argspec needed constrained
				set found 1
			}
		}
		if {!$found} {
			set given [linsert $given[set given {}] 0 $arg]
			break 
		}
	}


	if {[llength $given]} {
		if {![dict exists $doc extra]} {
			error [list {unknown argument} [lindex $given 0]]
		}
		set arg [dict get $doc extra]
		set argspec [dict get $docargs $arg]
		while {[llength $given]} {
			dict update docargs $arg argspec {
				dict incr argspec seen
			}
			checkarg 2 $arg given argspec needed constrained
		}
	}

	#process all the defaults before doing any of the constraints
	#otherwise, processing becomes sensitive to the order of arguments in the argspec
	dict for {arg argspec} $needed {
		if {[dict exists $argspec default]} {
			if {[dict get $argspec default] eq {}} {
				dict unset docargs $arg
			} else {
				dict incr argspec seen
				dict set seen $arg $argspec
				dict unset docargs $arg

				set given [list [uplevel 1 [dict get $argspec default]]] 

				checkarg 2 $arg given argspec needed constrained
			}
		}
	}

	dict for {arg argspec} $needed {
		if {!([dict exists $argspec default] 
			&& [dict get $argspec default] eq {})} {
			return -level 2 -code error  [list {missing mandatory argument} $arg] 
		}
	}


	foreach {arg constrain} $constrained[set constrained {}] {
		if {![uplevel 1 [list $info_ exists $arg]]} {
			continue
		}
		set constrainres [uplevel 1 [list $expr_ $constrain]]
		if {!$constrainres} {
			lappend msg {fails constraint} [concat $constrain]
			if {[uplevel 1 [list $info_ exists $arg]]} {
				lappend msg argument $arg
			}
			return -level 2 -code error $msg
		}
	}
	return $finalres 
}


variable [nsjoin doc checkdargs] {
	description {
		Check arguments passed to a function against the argument specification
		for that function .
		
		faster, but with different semantics than checkargs
	}
	args {
		doc {
			description {
				The documentation for a function , which normally contains an
				"args" entry specifying its arguments .
			}
			keys {
				args {
					description {
						A list of arguments that may be provided when
						calling the function .  In contrast to "checkargs" ,
						defaults are processed in the order they occur in
						the specification rather than the order of $given .

					}
					keys {
						constrain {
							description {
								Processed after all defaults , and in the
								order presented in $doc . This allows for
								constraints that depend on other
								constraints .
							}
						}
						default {
							description {
								sets a default value . processed after all
								inputs are processed , and in the order of
								occurance in $doc .

								If this key is not present , the argument is
								mandatory 

							}
						}
					}
				}
			}
		}
		given {
			description {
				The arguments given for a particular call of a function.
				Because it is interpreted as a dictionary , if any key occurs
				more than once in $given , only the last occurence is used .  See
				[proc checkdargs] for an alternative processor .

			}
		}
	}
}


proc checkdargs {doc given} {
	variable dict_
	variable expr_
	variable info_
	uplevel 1 [list $dict_ with $given {}]
	upvar $doc[unset doc] doc
	upvar $given[unset given] given
	#make sure it's a dictionary
	dict info $given
	dict for {opt optspec} [dict get $doc args] {
		dict with optspec {
			if {![dict exists $given $opt]} {
				if {![dict exists $optspec default]} {
					return level 2 -code error [
						list {missing mandatory argument} $opt
					]
				}
				if {[dict exists $optspec default]} {
					uplevel 1 $default
				}
			}
			if {[uplevel 1 [list $info_ exists $opt]]} {
				if {[dict exists $optspec process]} {
					set process [dict get $optspec process]
					uplevel 1 $process
				}
			}
			if {[dict exists $optspec constrain]} {
				#note that constraints are executed in the order presented in the argument specification
				if {[regexp {[^[:space:]]} $constrain]} {
					#constrain is not empty
					set res [uplevel 1 [list $expr_ $constrain]]
					if {!$res} {
						return -level 2 -code error [
							list {failed constraint} argument $opt contraint \
								$constrain value [dict get $given $opt]
						]
					}
				}
			}
		}
	}
}


proc checkspec spec {
	set keys [dict get [set [nsjoin doc checkargs]] args doc keys args keys]
	dict for {arg argspec} [dict get $spec args] {
		dict for {key dummy} $argspec {
			if {![dict exists $keys $key]} {
				return -code error [list $key {not one of} [dict keys $keys]]
			}
		}
	}
}


stub const {name value} {
	package require {ycl eval}
	alias [nsjoin [yclprefix] eval upcall]
} {
	if {![absolute? $name]} {
		set name [upcall 1 normalize $name[set name {}]]
	}
	upcall 1 interp alias {} $name {} [nsjoin {} lindex] $value
}


proc copy {from to} {
	if {![absolute? $from]} {
		set from [uplevel 1 [list namespace which -command $from]]
	}
	if {![absolute? $to]} {
		set to [normalize $to [uplevel {namespace current}]]
	}
	set args [info args $from]
	set newargs [formals $from]
	set parent [namespace qualifiers $to]
	if {$parent eq {}} {
		set parent [globalns]
	}
	if {![namespace exists $parent]} {
		namespace eval $parent {}
	}
	proc $to $newargs [info body $from]
}


variable curried {}
stub curry {name args} {
	package require {ycl eval}
	alias [nsjoin [yclprefix] eval upcall]
} {
	variable curried
	set id [info cmdcount]
	dict set curried $id $args
	upcall 1 proc $name args "
		[list [namespace which docurry]] [list $id] {*}\$args
	"
	upcall 1 trace add command $name delete [
		list [namespace which deletecurry] $id]
	return
}


proc deletecurry {id args} {
	variable curried
	dict unset curried $id
	return
}


proc docurry {id args} {
	variable curried
	tailcall [
		namespace which tailcall] {*}[dict get $curried $id] {*}$args
}


stub dproc {name args body} {
	package require {ycl eval}
	alias [nsjoin [yclprefix] eval upcall]
} {
	upvar 1 [nsjoin doc $name] spec
	checkspec $spec
	upcall 1 proc $name $args $body
}


stub exists name {
	package require {ycl eval}
	alias [nsjoin [yclprefix] eval upcall]
} {
	if {![absolute? $name]} {
		set name [upcall 1 normalize $name]
	}
	expr {[upcall 1 namespace which $name] ne {}}
}


#value: the formal parameters of a procedure
stub formals proc {
	package require {ycl eval}
	alias [nsjoin [yclprefix] eval upcall]
} {
	if {![absolute? $proc]} {
		set proc [upcall 1 namespace which -command $proc]
	}
	set args [info args $proc]
	set newargs {} 
	foreach arg $args {
		if {[info default $proc $arg val]} {
			lappend newargs [list $arg $val]
		} else {
			lappend newargs $arg
		}
	}
	return $newargs
}


variable [nsjoin doc kvargs] {
	description {
		Create a script to process $args as key-value arguments .
	}
	args {
		keys {
			description {
				a list of argument names to accept
			}
		}
	}
}
proc kvargs keys {
	string map [list @spec@ $keys] {
		apply {{spec provided} {
			foreach key [dict keys $provided] {
				if {$key ni $spec} {
					error [list {unknown argument} $key]
				}
			}

		}} @spec@ $args
		dict with args {}
	}
}


proc lambda args {
	variable apply_
	switch [llength $args] {
		1 {
			set spec {}
			set args [lassign $args[set args {}] body]
		}
		0 {
			error [list {wrong # args}]
		}
		default {
			set args [lassign $args[set args {}] spec body]
		}
	}
	list $apply_ [list $spec $body [uplevel 1 {namespace current}]] {*}$args
}


proc lambdacurry args {
	variable tailcall_
	uplevel 1 [list [namespace which lambda] {args0 args} "
		[list $tailcall_] {*}\$args0 {*}\$args
	" $args]
}


proc lbody {args list} [string map [list @apply@ [list $apply_] @foreach@ [
	list $foreach_] @uplevel@ [list $uplevel_]] {
    list @apply@ [
        list [list list {*}$args] {
            @apply@ [list {} {
                upvar list list 
                @foreach@ line $list {
                    if {[catch {@uplevel@ 1 $line} cres copts]} {
                        dict incr copts -level
                        return -options $copts $cres
                    }
                }
				return $cres
            } [namespace current]]
        } [uplevel 1 {namespace current}]
    ] $list
}]


stub lproc {name args list} {
	package require {ycl eval}
	alias [nsjoin [yclprefix] eval upcall]
} {
	variable interp_
    uplevel 1 [list $interp_ alias {} [upcall 1 normalize $name] {} {*}[
		uplevel 1 [list [namespace which lbody] $args $list]]]
}


#like builtin proc, but $vars specifies namespace variables to make available
stub nsproc {name args vars body} {
	package require {ycl eval}
	alias [nsjoin [yclprefix] eval upcall]
} {
	foreach var $vars {
		append pre "variable [list $var]\n"
	}
	append pre $body
	upcall 1 proc $name $args $pre
}


proc vmacro {mspec args} {
	if {[llength $mspec] != 2} {
		return -code error [
			list {wrong # args} allowed 2 received $mspec]
	}
	lassign $mspec margs body
	if {[llength $margs] != [llength $args]} {
		return -code error [
			list {wrong # args} expected [llength $margs] received [
				llength $args] args $args]
		]

	}
	foreach marg $margs arg $args {
		lappend map \${$marg} \${$arg}
		lappend map "{{$marg}}" [list $arg]
	}
	set body [string map $map $body[set body {}]]
	uplevel $body
}

variable [nsjoin doc method] {
	description
		create a procedure
	args
		attributes
			names of variables to link to in the namespace of the object
		vars
			names of variables to link to in the namespace of the procedure 
}


stub method {object name args vars attributes body} {
	package require {ycl eval}
	alias [nsjoin [yclprefix] eval upcall]
} {
	variable proc_
	foreach var $vars {
		append pre "variable [list $var]\n"
	}
	set ns [upcall 1 namespace ensemble configure $object -namespace]
	foreach attribute $attributes {
		append pre "namespace upvar [list $ns]  [
				list $attribute] [list $attribute]\n"
	}

	append pre $body[set body {}]
	namespace eval $ns [list $proc_ $name $args $pre]
}


proc optswitch {opt switch} {
	variable error_
	variable switch_
	lappend switch default [
		list $error_ [list {unknown option} $opt]]
	tailcall $switch_ $opt $switch
}


proc partial {cmd args} {
	variable apply_
	variable tailcall_
	list $apply [list {cmd baked args} {
		$tailcall $cmd {*}$baked {*}$args
	} [uplevel 1 {namespace current}]] $cmd $args
}


variable [nsjoin doc replace] {
	description {
		create a procedure and replace the current routine by calling the new
		procedure with the provided arguments.
	}
}
stub replace {name spec body args} {
	package require {ycl eval}
	alias [nsjoin [yclprefix] eval upcall]
} {
	variable tailcall_
	upcall 1 proc $name $spec $body
	$tailcall_ $tailcall_ $name {*}$args
}


proc validatespec specname  {
	namespace upvar doc checkargs doc
	upvar $specname spec
	set specargs [dict get $spec args]
	dict size $specargs
	foreach {name spec1} $specargs {
		dict size $spec1
		foreach {skey sval} $spec1 {
			set allowed [dict keys [dict get $doc args doc keys args keys]]
			if {$skey ni $allowed} {
				error [list {bad documentation} name $skey]
			}
		}
	}
	dict set spec validated 1
}