#! /bin/env tclsh
apply [list {} [string map [list \
@makemy@ {
proc ${ns}::.my args [string map [list @self@ [list $to]] {
::tailcall @self@ {*}$args
}]
}
] {
package require {ycl proc}
namespace import [yclprefix]::proc::checkargs
namespace import [yclprefix]::proc::exists
package require {ycl ns}
namespace import [yclprefix]::ns::duplicate
namespace import [yclprefix]::ns::ensemble
namespace import [yclprefix]::ns::normalize
namespace import [yclprefix]::ns::unique
package require {ycl shelf util}
namespace import [yclprefix]::shelf::util::asmethod
namespace import [yclprefix]::shelf::util::.apply
namespace import [yclprefix]::shelf::util::.attribute
namespace import [yclprefix]::shelf::util::.plugin
namespace import [yclprefix]::shelf::util::.vars
set exports [namespace eval :: {namespace export}]
namespace eval :: {namespace export *}
namespace import ::apply
rename [namespace current]::apply methoddispatch
namespace import ::apply
rename [namespace current]::apply cmddispatch
namespace eval :: {namespace export} $exports
package require {ycl var methods}
proc applytemplate {apply body} {
string map [list @applytemplate@ [
list [string map [list @apply@ $apply] {
# This resulted in generation of string representations for all
# items in $args
#::tailcall ::apply [list args [
# list ::tailcall $target {*}$targetargs $_ {*}$args] $ns]
set ns [namespace ensemble configure $context -namespace]
set stack [.state $_ get stack]
lappend stack $context
.state $_ set stack $stack
set sig [.state $_ get sig]
@apply@
if {[namespace which $_] eq $_} {
set sig2 [.state $_ get sig]
if {$sig == $sig2} {
set stack [lreplace [.state $_ get stack] end end]
.state $_ set stack $stack
}
}
dict incr copts -level
return -options $copts $cres
}]]] $body
}
proc .~ {_ args} {
}
proc .basis {_ args} {
set map [namespace ensemble configure $_ -map]
set body [dict get $map .basis]
if {[llength $args] == 1} {
set new [lindex $args 0]
if {![string match ::* $new]} {
set new_orig $new
set new [uplevel 1 [list ::namespace which $new]]
if {$new eq {}} {
error [list {no such shelf} $new_orig]
}
}
set body [lreplace $body[set body {}] 4 4 $new]
dict set map .basis $body
namespace ensemble configure $_ -map $map
return [lindex $args 0]
} elseif {[llength $args] == 0} {
return [lindex $body 4]
} else {
error [list {wrong number of args} [llength $args]]
}
}
proc .clone {_ to} {
if {$to eq {}} {
set to [namespace current]::[info cmdcount]
}
if {[uplevel 1 [list [namespace which exists] $to]]} {
uplevel 1 [list ::rename $to {}]
}
if {[uplevel 1 [list ::namespace exists $to]]} {
uplevel 1 [list ::namespace delete $to]
}
uplevel 1 [list [namespace which duplicate] $_ $to]
set to [uplevel 1 [list [namespace which ensemble] duplicate $_ $to]]
set map [namespace ensemble configure $to -map]
.basis $to [$_ .basis]
# because disposal involves a trace , it isn't sufficient to duplicate the
# ensemble and the namespace . Reset it .
$_ .state set sig [info cmdcount]
set ns [namespace ensemble configure $to -namespace]
@makemy@
$to .disposal [lindex [$_ .disposal] 0]
set to [$to .cloned]
return $to
}
proc .cloned _ {
return $_
}
proc .disposal {_ args} [list ::apply [list {oldcmd disposal} [
string map [list @method@ [asmethod [set [yclprefix]::ns::disposal]]] {
upvar 1 _ _ args args
set old [$_ .state get disposal]
lassign $old oldcmd disposal
if {[llength $args]} {
set cmd [lindex $args 0]
set trace [::apply [list @method@ [namespace current]] $_ [
$_ .namespace] $cmd]
if {$cmd eq {}} {
trace remove command $_ delete $oldcmd
} else {
$_ .state set disposal [list $cmd $trace]
}
} else {
return $old
}
}] ] {} {}]
proc .eject {_ shelf} {
if {![string match ::* $shelf]} {
set shelf_orig $shelf
set shelf [uplevel 1 [list namespace which $shelf]]
if {$shelf eq {}} {
error [list {no such shelf} $shelf_orig]
}
}
set current $_
set eject 0
while {[set candidate [$current .basis]] ne $current} {
if {$candidate eq $shelf} {
$current .basis [$shelf .basis]
set eject 1
break
}
set current $candidate
}
if {!$eject} {
error [list {not in the hierarchy} $shelf]
}
}
proc .inject {_ shelf} {
uplevel 1 [list $shelf .basis [$_ .basis]]
uplevel 1 [list $_ .basis $shelf]
uplevel 1 [list $shelf .configure injected true]
return
}
proc $.locate {_ name} {
set location [namespace which -variable [$_ .namespace]::$name]
if {$location eq {} || ![info exists $location]} {
while {[set basis [$_ .basis]] ne $_} {
set info [$basis .state get]
try {
# Can't use [.configure] here to get the value of injected
# because [.configure] itself uses [$.locate]
if {!![dict get $info .conf injected]} {
set _ $basis
continue
}
} on error {} {}
set location [namespace which -variable [$basis .namespace]::$name]
if {$location ne {} && [info exists $location]} {
return $location
}
set _ $basis
}
return -code error --errorcode [
list SHELF VAR LOOKUP VARNAME $name] \
[list {can't read} $name {no such variable}]
}
return $location
}
# To do: Maybe [.method] should, like [.routine] resolve the target at invocation
# time relative to the namespace of the shelf.
variable doc::.method {
description {
Make a prefix a method of a shelf .
If one argument is given, it is a
command prefix, to which
} args {
name {
description {
The name of the subcommand for the shelf.
}
}
args {
description {
The first argument is a command prefix to which the the
fully-qualified name of the shelf is append as an argument when
the method is invoked, followed by any remaining arguments.
}
}
}
}
proc .method {_ name args} [applytemplate {
catch [list ::uplevel 1 [list ::apply [list {_ args1 args2 otherargs} {
::tailcall {*}$args1 $_ {*}$args2 {*}$otherargs
} $ns] $_ $args1 $args2 $args]] cres copts
} {
if {[llength $args] == 0} {
set args1 [list $name]
set args2 {}
set name [namespace tail $name]
} elseif {[llength $args] < 3} {
lassign $args args1 args2
} else {
error [list {wrong # args}]
}
set map [namespace ensemble configure $_ -map]
if {0 && [string match ::* [lindex $args1 0]]} {
# [.switch] relies on the fact that each script in an ensemble map is a
# list in which element 3 is the namespace for the evaluation, so this
# optimization can no longer be used.
#dict set map $name [list {*}$args1 $_ {*}$args2]
} else {
# See the comment for the analogous command in [routine]
dict set map $name [list methoddispatch [
list {name _ context args1 args2 args} @applytemplate@ [
namespace current]] $name $_ $_ $args1 $args2]
}
namespace ensemble configure $_ -map $map
}]
proc .namespace _ {
namespace ensemble configure $_ -namespace
}
proc .namespace {_ args} {
namespace ensemble configure $_ -namespace
}
proc .renamed {_ oldname newname op} {
set map [namespace ensemble configure $newname -map]
set newmap {}
set mapper {
switch $word $oldname {
lindex $newname
} default {
lindex $word
}
}
dict for {key command} $map {
set command [lmap word $command[set script {}] $mapper]
dict set newmap $key $command
}
namespace ensemble configure $newname -map $newmap
}
variable doc::.routine {
description {
Add a subcommand to the shelf that, when invoked, causes the target
command to be invoke. If the name of the target command is not
absolute, the command is resolved relative to the namespace of the
shelf.
}
}
proc .routine {_ cmd args} [applytemplate {
catch [list uplevel 1 [::list ::apply [list args {::tailcall {*}$args} $ns] {*}$args]] cres copts
} {
if {[llength $args]} {
#set target [lindex $args 0]
set target $args
} else {
# $target is expected to be a list
set target [list $cmd]
set cmd [namespace tail $target]
}
set map [namespace ensemble configure $_ -map]
if {0 && [string match ::* $target]} {
# See notes in [method] about not using this optimization because
# [backtrack] and [.switch] expect a certain command layout
# dict set map $cmd $target
} else {
# The purpose of this complexity is to allow $target to be resolved in
# the scope of $_ , but invoked in the scope of the caller of the
# ensemble , while still keeping $_ as a word in the ensemble map so
# that it is replaced during duplication by [ns ensemble duplicate] . If
# there's a more simple way to accomplish this , I'd like to hear about
# it .
# Also, $target is expanded directly in the command prefix for the map
# for the same reason : So that any occurrences of the ensemble or its
# namespace are substituted during a [ns ensemble duplicate] operation .
dict set map $cmd [list cmddispatch [
list {_ context args} @applytemplate@ [
namespace current]] $_ $_ {*}$target]
}
namespace ensemble configure $_ -map $map
}]
proc .site {_} {
lindex [.state $_ get stack] end-1
}
proc .switch {_ cmd args} {
if {$cmd eq {shelf}} {
set args [lassign $args[set args {}] shelf cmd]
} else {
set stack [$_ .state get stack]
# -1 for switch and -1 for the call to .state
set shelf [lindex $stack end-2]
set shelf [$shelf .basis]
}
set script [resolve $_ $shelf $cmd]
if {$script eq {}} {
error [list {uknown command} $cmd]
}
tailcall {*}$script {*}$args
}
proc .wrap {_ cmd} {
if {[$_ .state exists wrapped]} {
set wrapped $_ .state get wrapped
error [list {already wrapping} $wrapped]
}
$_ .state set wrapped [list ::apply [list args {
::tailcall {*}$args
} [uplevel 1 {namespace current}]] {*}$cmd]
return
}
proc .wrapped {_ args} {
set wrapped [$_ .state get wrapped]
::tailcall {*}$wrapped {*}$args
}
# {to do} {
# .routines currently doesn't return all commands that would be properly
# resolved by [resolve]
# }
proc .routines _ {
set res [dict keys [namespace ensemble configure $_ -map]]
while {[set basis [.basis $_]] ne $_} {
lappend res {*}[dict keys [namespace ensemble configure $basis -map]]
set _ $basis
}
set res [lsort -uniq $res[set res {}]]
return $res
}
proc .spawn {_ to} {
if {$to eq {}} {
set to [namespace current]::[info cmdcount]
}
if {$to eq {}} {
while 1 { set to [namespace current]::[info cmdcount]
if {[namespace which $to] eq {}} break
}
} else {
if {[uplevel 1 [list [namespace which exists] $to]]} {
uplevel 1 [list ::rename $to {}]
}
if {[uplevel 1 [list ::namespace exists $to]]} {
uplevel 1 [list ::namespace delete $to]
}
}
# Create $to so that the namespace isn't duplicated when the ensemble is
# duplicated , per {ycl ns duplicate} . This is the big difference
# between [.clone] and [.spawn] .
set to [uplevel 1 [list namespace eval $to {namespace current}]]
namespace eval $to [list namespace eval doc {}]
# Although the namespace isn't duplicated, the path must be duplicated.
# For one thing, this enables us to call the [.disposal] method in a moment.
set newpath {}
foreach item [list [$_ .namespace] {*}[
namespace eval [$_ .namespace] {namespace path}] {*}[
namespace eval $to {namespace path}]] {
if {$item ni $newpath} {
lappend newpath $item
}
}
namespace eval $to [list namespace path $newpath]
set to [uplevel 1 [list [namespace which ensemble] duplicate $_ $to]]
set info [$_ .state get]
dict set map .basis [dict get [namespace ensemble configure $to -map] .basis]
namespace ensemble configure $to -map $map
.basis $to $_
namespace ensemble configure $to -unknown [list ::apply [list {info _ routine args} {
#{
# This this entire method dispatch mechanism must not itself invoke
# any methods on the object, or [$_ .inner] will then return the
# wrong value
#}
##
if {[.state $_ exists plugged]} {
set context [.state $_ get plugged]
} else {
set context $_
}
set script [resolve $_ $context $routine]
if {![llength $script]} {
error [list {unknown command} $routine for $_ {should be one of} [
.routines $_]]
}
return $script
} [namespace current]] $info]
$_ .state set sig [info cmdcount]
set ns [namespace ensemble configure $to -namespace]
@makemy@
trace add command $to rename [list $to .renamed]
$to .disposal [lindex [$_ .disposal] 0]
set to [$to .spawned]
return $to
}
proc .spawned _ {
return $_
}
namespace eval .state {
namespace ensemble create -parameters _
namespace export *
namespace ensemble configure [namespace current] -map {
exists exists get get replace replace set .set
}
proc replace {_ value} {
set unknown [lreplace [
namespace ensemble configure $_ -unknown] 2 2 $value]
namespace ensemble configure $_ -unknown $unknown
return $value
}
proc exists {_ args} {
set unknown [namespace ensemble configure $_ -unknown]
set info [lindex $unknown 2]
return [dict exists $info {*}$args]
}
proc get {_ args} {
set unknown [namespace ensemble configure $_ -unknown]
set info [lindex $unknown 2]
if {[llength $args]} {
return [dict get $info {*}$args]
} else {
return $info
}
}
proc .set {_ args} {
set unknown [namespace ensemble configure $_ -unknown]
set info [lindex $unknown 2]
dict set info {*}$args
set unknown [lreplace $unknown[set unknown {}] 2 2 $info]
namespace ensemble configure $_ -unknown $unknown
set res [get $_ {*}[lrange $args 0 end-1]]
return $res
}
}
proc resolve {_ basis routine} {
set current $_
while 1 {
set map [namespace ensemble configure $basis -map]
# if $_ eq $basis, this method has been invoked directly on the object,
# so it should be returned if found in the map
if {[dict exists $map $routine]} {
set script [dict get $map $routine]
set mapper {
switch $word $basis {
lindex $_
} default {
lindex $word
}
}
set script [lmap word $script[set script {}] $mapper]
set name [lindex $script 0]
switch [namespace tail $name] [list \
methoddispatch {
set script [lreplace $script[set script {}] 4 4 $basis]
#set script [lreplace $script[set script {}] 3 3 $_]
} cmddispatch {
set script [lreplace $script[set script {}] 2 2 $basis]
} default {
error [list {unknown routine} $routine]
}
]
return $script
}
set current $basis
set basis [.basis $basis]
if {$basis eq $current} {
break
}
}
# If nothing was found, forward to wrapped command
if {[.state $_ exists wrapped]} {
set script [list {*}[.state $_ get wrapped] $routine]
return $script
}
# If the end of resolve is reached, the routine was not found. Return
# nothing
return
}
variable doc::.configure {
description {
Manage configuration data related to the shelf itself .
Arguments are taken as a dictionary . If there
is an odd number of arguments and the first argument is "!"
(exclamation) , admin mode is activated , which permits configuring
items that are normally read-only .
}
args {
_ {
description {
The current object
}
}
configure_template {
default {}
automatic true
}
injected {
default {}
}
}
}
proc .configure {_ args} [string map [list \
@checkargs@ checkargs \
@doc@ {$_ $ doc::.configure} \
@get@ {.state $_ get .conf $name} \
@exists@ {$_ .state exists .conf $name} \
@self@ {$_} \
@set@ {.state $_ set .conf $name $value}] [
[yclprefix] shelf util configure_template
] \
]
variable doc::configure {
description {
Manage configuration data related to the the thing the shelf models, in
the same way that [.configure] does for the shelf itself.
}
}
dict set doc::configure args [dict get ${doc::.configure} args]
proc configure {_ args} [string map [list \
@checkargs@ checkargs \
@doc@ {$_ $ doc::configure} \
@get@ {$_ $ $name} \
@exists@ {$_ $.exists $name} \
@set@ {$_ $ $name $value}] [
[yclprefix] shelf util configure_template
]
]
variable doc::init {
description {
synopsis {
transform a namespace into a shelf , i.e. , an object with the
behaviours described here .
}
description [
{
The [configure] and [.configure] facilities are for data that
might be changed by an external party
}
{
The [.state] facility is for data that might be changed the
shelf itself
}
]
notes [
{This is another attempt at an object system, initiated 2015-01}
{
The goal is to create an object system closely-aligned with the
capabilities of [namespace], and hopefully in harmony with the
intention of its design . The namespace path is used for command
resolution , and the namespace ensemble map specifies the public
programming interface of the object . A method is simply a procedure
that is called through the public interface , and doesn't necessarily
even take the name of the object as its first argument . Where it does
, that is defined in the namespace ensemble map.
}
{
This object system gives up on the idea of methods being procedures
that look up one level to find their object , and instead uses the
namespace map to make the object's interface explicit . There is no
mechanism for private methods , so a naming convention might be used
instead .
}
{The predecessors of this system were {ycl context} and {ns object} .}
]
Implementation [
{
Each entry in an ensemble map records a subcommand at that site .
The -unknown routine looks up entries in ensembles further up the
hierarchy .
}
]
}
args {
_ {}
}
}
proc init {_ args} {
namespace upvar $_ doc::init doc
if {[info exists doc]} {
checkargs $doc {*}$args
} else {
checkargs [$_ $ doc::init] {*}$args
}
return $_
}
namespace ensemble configure [namespace current] -unknown {::apply {args {
# dummy unknown , so that that shelf at the top has an info value ,
# which is element 2 of the -unknown value .
}} {}}
.state [namespace current] set sig [info cmdcount]
.state [namespace current] set disposal {}
.state [namespace current] set stack {}
set methoddata [[yclprefix]::var::$ {{varname args} {} {}} {[$_ $.locate $varname]} \
{set ${_}::$varname $val} {[set ${_}::$varname]}]
proc $ {*}[asmethod $methoddata]
set methoddata [[yclprefix]::var::$.exists {{varname args} {} {}} \
{[list $_ $ $varname]} {$_ $ $varname}]
proc $.exists {*}[asmethod $methoddata]
#set methoddata [[yclprefix]::var::$.locate {varname {} {}} {${_}::$varname} \
# {[$_ .basis] ne $x} {$path $.locate $varname}]
#proc $.locate {*}[asmethod $methoddata]
# Bootstrap the first shelf . Assume that the name of the current namespace
# is the name of the ensembles .
foreach procname {$ $.exists $.locate .~ .attribute .basis .clone .cloned
.configure .disposal .eject .state .inject .method .namespace .plug .plugin
.renamed .routine .routines .site .spawn .spawned .vars .wrap .wrapped
configure init
} {
# To make behaviour less surprising for a shelf that overrides built-in
# methods , use the variant of [method] that looks up the procedure at
# runtime .
#method [namespace current] $procname [namespace which $procname]
.method [namespace current] $procname
}
.method [namespace current] .plug [list [yclprefix]::shelf::util::.nsshelf_plug] [
list [namespace current]]
.method [namespace current] .switch
.method [namespace current] .apply
.method [namespace current] .namespace [list [namespace which .namespace]]
.routine [namespace current] .eval ::namespace eval [namespace current]
.method [namespace current] .basis
[namespace current] .disposal .~
rename applytemplate {}
interp alias {} [namespace current]::.my {} ::apply [list {_ args} {
::tailcall $_ {*}$args
} [namespace current]] [namespace current]
}] [namespace current]]