#! /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
ot the procedure, and is processed as specified in the
"keys" document node.
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 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]
}
}
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 {}
}
}
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 occurance 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 evaluating to an 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
}
}
}
}
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 name> <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 docname {
if {[string match ::* $docname ]} {
set docname [uplevel {namespace current}]::$docname
}
uplevel [list upvar $docname doc]
upvar $docname doc
upvar args given
set positional [uplevel [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 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 seen $arg 0
}
if {[dict exists $argspec init]} {
uplevel [dict get $argspec init]
}
}
set stopscript [dict get [dict merge [dict create stop {}] $doc] stop]
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} {
return -level 2 -code error "mandatory argument \"$arg\" is missing"
}
}
foreach arg $positional {
uplevel [list [namespace current]::checkarg $arg [
uplevel [list set $arg]] $doc $seen $stopscript]
}
if {[info exists given]} {
foreach {arg val} $given {
set argspec [dict get $doc args $arg]
uplevel [list [namespace current]::checkarg \
$arg $val $doc $seen $stopscript]
}
}
#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 {[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
}
proc checkarg {arg val doc seen stopscript} {
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 [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]]
}
if {$stopscript ne {}} {
if {[set stop [uplevel [list expr $stopscript]]]} {
break
}
}
}
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
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 upmethod {name args vars attributes 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 save [namespace eval [namespace qualifiers $fulltarget] {
namespace export}]
namespace eval [namespace qualifiers $fulltarget] {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 [namespace qualifiers $fulltarget] [
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]]
}
proc argnames {} {
set cmd [uplevel info level 0]
set args [lassign $cmd name]
if {![string match ::* $name]} {
set name [uplevel [list uplevel [list namespace which $name]]]
}
if {$name eq {::apply}} {
set args [lindex $args 0 0]
} else {
set args [info args $name]
}
return $args
}
variable methodvar _