#! /bin/env tclsh
namespace eval doc {}
variable 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 name of a variable containing documentation for a
function , which normally contains an "args" entry specifying
its arguments .
creates a variable named "doc" in the caller .
}
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 .
}
}
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 .
}
}
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
}
}
}
}
extra {
description {
The name of variable in which to accumulate
unrecognized $variable is a containing an even number
of values representing key-value pairs , where some keys
may be identical .
}
}
stop {
description {
A value that signals that no more arguments
should be processed .
}
}
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 .
}
}
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 .
$given is evaluated as 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 docname {
if {![string match ::* $docname]} {
set docname [uplevel {::namespace current}]::$docname
}
uplevel [list ::upvar $docname doc]
upvar $docname doc
set doc [dict merge {args {}} $doc[set doc {}]]
upvar args given
set positional [uplevel [list [namespace current]::argnames]]
if {[info exists given]} {
set positional [lrange $positional[set positional {}] 0 end-1]
}
set seen [dict create]
set mandatory [dict create]
set res [dict create]
dict for {arg argspec} [dict get $doc args] {
#make sure it's a dictionary
dict info $argspec
if {![dict exists $argspec default]} {
dict set seen $arg 0
}
if {[dict exists $argspec init]} {
uplevel [dict get $argspec init]
}
}
foreach arg $positional {
dict incr seen $arg
}
if {[info exists given]} {
foreach {arg val} $given {
dict incr seen $arg
}
}
dict for {arg val} $seen {
if {!$val && (![dict exists $doc extra] || [dict get $doc extra] ne $arg)} {
return -level 2 -code error [list {missing mandatory argument} $arg]
}
}
foreach arg $positional {
uplevel [list [namespace current]::checkarg $arg [
uplevel [list ::set $arg]] $doc $seen]
}
set argsidx 0
set finalres {}
if {[dict exists $doc stop]} {
set stop [dict get $doc stop]
}
if {[info exists given]} {
foreach {arg val} $given {
if {[info exists stop] && $arg eq $stop} {
incr argsidx
set finalres [lrange $given $argsidx end]
break
}
incr argsidx 2
if {[dict exists $doc args $arg]} {
set argspec [dict get $doc args $arg]
uplevel [list [namespace current]::checkarg $arg $val $doc $seen]
} else {
if {![dict exists $doc extra]} {
error [list {unknown argument} $arg $val]
}
dict incr seen [dict get $doc extra]
uplevel [list ::lappend [dict get $doc extra] $arg $val]
}
}
}
#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} [dict get $doc args] {
if {![dict exists $seen $arg]} {
if {[dict exists $argspec default] && [
dict get $argspec default] ne {}} {
uplevel [list ::set $arg [uplevel [dict get $argspec default]]]
if {[dict exists $argspec process]} {
set process [dict get $argspec process]
uplevel [list ::set $arg [uplevel $process]]
}
}
}
}
dict for {arg argspec} [dict get $doc args] {
if {![uplevel [list ::info exists $arg]]} {
continue
}
if {[dict exists $argspec constrain]} {
set constrain [dict get $argspec constrain]
set constrainres [uplevel [list ::expr $constrain]]
if {!$constrainres} {
set msg "\$$arg fails constraint: $constrain"
if {[uplevel [list ::info exists $arg]]} {
append msg "value for \$$arg was [uplevel [list ::set $arg]]"
}
return -level 2 -code error $msg
}
}
}
return $finalres
}
proc checkarg {arg val doc seen} {
dict incr res next 2
if {![dict exists $doc args $arg]} {
if {![dict exists $doc extra]} {
return -code error "no such argument: $arg"
}
set val [list $arg $val]
set arg [dict get $doc extra]
}
set argspec [dict get $doc args $arg]
if {[dict exists $seen $arg]} {
set count [dict get $seen $arg]
if {[dict exists $argspec count]} {
set countspec [dict get $argspec count]
} else {
set countspec 1
}
if {$countspec == -1} {
#no problem
} elseif {$count > $countspec} {
return -level 2 -code error "argument allowed $countspec times, but seen $count times: $arg"
}
}
if {[dict exists $argspec name]} {
uplevel [list ::set [dict get $argspec name] $val]
} else {
uplevel [list ::set $arg $val]
}
if {[dict exists $argspec validate]} {
set validate [dict get $argspec validate]
if {[regexp {[^[:space:]]} $validate]} {
#validate is not empty
set vres [uplevel [list ::expr $validate]]
if {!$vres} {
return -level 2 -code error \
"value [list $val] for argument \$$arg fails validation: $validate"
}
}
}
if {[dict exists $argspec process]} {
set process [dict get $argspec process]
uplevel [list ::set $arg [uplevel $process]]
}
}
variable 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} {
uplevel [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 "mandatory argument \"$opt\" is missing"
}
if {[dict exists $optspec default]} {
uplevel $default
}
}
if {[uplevel [list ::info exists $opt]]} {
if {[dict exists $optspec process]} {
set process [dict get $optspec process]
uplevel $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 [list ::expr $constrain]]
if {!$res} {
return -level 2 -code error \
"value \"[dict get $given $opt]\" for argument \$$opt fails constraint: $constrain"
}
}
}
}
}
}
proc checkspec spec {
set keys [dict get $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]]
}
}
}
}
proc dproc {name args body} {
upvar doc::$name spec
checkspec $spec
uplevel [list ::proc $name $args $body]
}
#value: the formal parameters of a procedure
proc formals proc {
if {[string first :: $proc] != 0} {
set proc [uplevel [list ::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
}
#like builtin proc, but $vars specifies namespace variables to make available
proc nsproc {name args vars body} {
foreach var $vars {
append pre "variable [list $var]\n"
}
append pre $body
uplevel [list ::proc $name $args $pre]
}
proc vmacro {mspec args} {
if {[llength $mspec] != 2} {
return -code error "wrong # args. Should be 2. Instead, got $mspec"
}
lassign $mspec margs body
if {[llength $margs] != [llength $args]} {
return -code error \
"wrong # args. Expected [llength $margs] but got [llength $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 doc::method {
description {
Designed to work with {ycl ns type}, allows methods to be inherited
from other objects.
in contrast with upmethod a method must be a namespace subcommand of
the object, so an upmethod which resides outside the object must be
[namespace imported] into the object before it can be called.
In the method, a special variable, usually $_ holds the full name of
the object, and can be used to call other methods of the object or
access members of the object.
Any object hierarchies that use method should take care not to have a
method and an upmethod with the same name in the same object hierarchy,
or there will be blood.
}
}
proc method {name args vars attributes body} {
variable methodvar
set pre [string map [list {{{methodvar}}} [list $methodvar]] {
set {{methodvar}} [namespace qualifiers [namespace which [
lindex [info level 0] 0]]]
}]
foreach var $vars {
append pre "variable [list $var]\n"
}
foreach attribute $attributes {
append pre "namespace upvar \$_ [list $attribute] [list $attribute]\n"
}
append pre $body[set body {}]
uplevel [list ::proc $name $args $pre]
}
variable doc::upmethod {
description {
like method, but designed to work with {ycl ns parent}
Intended for use via ns::layer
Any object hierarchies that use method should take care not to have a
method and an upmethod with the same name in the same object hierarchy,
or there will be blood.
upmethod only provides the underlying namespace for an object called
through a namespace ensemble command, so it may only be useful for
object systems in which the name of the ensemble command is guaranteed
to be the same as the name of the namespace.
}
}
proc upmethod {name args attributes vars body} {
variable methodvar
append pre [string map [list {{{methodvar}}} [list $methodvar]] {
::set {{methodvar}} [::uplevel {::namespace current}]
}]
foreach var $vars {
append pre "::variable [list $var]\n"
}
foreach attribute $attributes {
append pre "::namespace upvar \$_ [list $attribute] [list $attribute]\n"
}
append pre $body[set body {}]
uplevel [list ::proc $name $args $pre]
}
proc alias {alias target} {
set fulltarget [uplevel [list ::namespace which $target]]
if {$fulltarget eq {}} {
return -code error [list {no such command} $target]
}
set qualifiers [namespace qualifiers $fulltarget]
if {$qualifiers eq {}} {
set qualifiers ::
}
set save [namespace eval $qualifiers {
namespace export}]
namespace eval $qualifiers {namespace export *}
while {[namespace exists [
set tmpns [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 {*}$save]
if {$code} {
return -options $copts $cres
}
uplevel [list ::rename ${tmpns}::[namespace tail $target] $alias]
namespace delete $tmpns
return [uplevel [list ::namespace which $alias]]
}
variable doc::argnames {
description {
"argnames" returns the argument names of the procedure that calls it.
}
}
proc argnames {} {
set cmd [uplevel {::info level 0}]
set args [lassign $cmd name]
set oldname $name
if {![string match ::* $name]} {
#do [uplevel 2 ...] first in order to catch renamed imported commands.
if {[set name [uplevel 2 [list ::namespace which $oldname]]] eq {}} {
set name [uplevel 1 [list ::namespace which $oldname]]
}
}
set name [namespace origin $name]
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
}
variable methodvar _