#! /bin/env tclsh
namespace eval doc {}
#value: the formal parameters of a procedure
proc formals proc {
set callingspace [uplevel 1 namespace current]
set args [info args $proc]
set newargs [list]
foreach arg $args {
if {catch {namespace eval $callingspace [ \
list info default $proc $arg]} val} {
lappend newargs [list $arg $val]
} else {
lappend newargs $arg
}
}
return $newargs
}
variable doc::checkargs {
description {
check arguments passed to a function against the argument specification
for that function. functions utilizing this protocl must be invoked
with keyword arguments only.
note that this documentation is "fake" in the sense that it isn't
parsed by checkargs. We are not Baron Münchhausen!
}
args {
doc_ {
description {
the name of a variable containging documentation for a
function, which normally contains an "args" entry specifying
its arguments.
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. For each key, the value
given in the function call for that argument is
assigned to an identically-named variable within
the function. This assignment happens prior to the
evalution of doc sections such as "validate" and
"process".
}
keys {
constrain {
description {
evaluated as an expression
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 and 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]
}
}
validate {
description {
evaluated as an expression
processed as each argument is encountered.
Intended primarily to check that input
matches a certain pattern.
}
}
default {
description {
sets the default value. Also indicates
that the argument is optional
processed after all inputs are processed,
and in the order of occurance in $doc
}
}
process {
description {
a script to invoke as the argument is
encountered
default arguments are "encountered" as
described in their documentation
}
}
}
}
extra {
description {
the name of a key in $args, designating an argument
specification that will be used when extra
arguments are encountered. The corresponding
argument variable will be transformed into a {key,
val}. For example, if $args contains the key,
"mystery_arg", and $extra is set to
"mystery_arg", then the variable $mystery_arg will
be the list {<actual arg> <actual value>}
}
}
stop {
description {
an expression evaluated for each argument in $given
,which ,if true ,indicates 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: implment 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 {doc_ given_} {
upvar $doc_ doc
upvar $given_ given
set seen [dict create]
set mandatory [dict create]
set stop 0
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 mandatory $arg 0
}
}
set stopscript [dict get [dict merge [dict create stop {}] $doc] stop]
foreach {arg val} $given {
dict incr mandatory $arg
}
dict for {arg val} $mandatory {
if {!$val} {
return -level 2 -code error "mandatory argument \"$arg\" is missing"
}
}
foreach {arg val} $given {
dict incr seen $arg
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"
}
}
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 \"[dict get $given $arg]\" for argument \$$arg fails validation: $validate"
}
}
}
if {[dict exists $argspec process]} {
set process [dict get $argspec process]
uplevel $process
}
if {$stopscript ne {}} {
if {[set stop [uplevel [list expr $stopscript]]]} {
break
}
}
}
dict for {arg argspec} [dict get $doc args] {
dict with argspec {
if {![dict exists $given $arg]} {
if {[dict exists $argspec default]} {
uplevel $default
#only process if the argument exists after evaluating default script
if {[uplevel [list info exists $arg]] && [dict exists $argspec process]} {
set process [dict get $argspec process]
uplevel $process
}
}
}
if {[dict exists $argspec constrain]} {
set constrain [dict get $argspec constrain]
set res [uplevel [list expr $constrain]]
if {!$res} {
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 $res
}
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_} {
upvar $doc_ doc
upvar $given_ given
uplevel [list dict with $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"
}
}
}
}
}
}