#! /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::.disposal
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
proc $ {_ varname args} {
switch [llength $args] {
0 {
return [set [$_ $.locate $varname]]
}
1 {
lassign $args val
set ${_}::$varname $val
return [set ${_}::$varname]
}
default {
error [list {wrong # args}]
}
}
}
proc .invoke {_ args} {
::tailcall ::namespace eval [$_ .namespace] $args
}
proc .eval {_ args} {
namespace eval [$_ .namespace] {*}$args
}
proc $.exists {_ varname args} {
if {[catch {$_ $ $varname}]} {
if {[llength $args]} {
lassign $args val
$_ $ $varname $val
return 1
} else {
return 0
}
} else {
return 1
}
}
proc .~ {_ args} {
}
proc .basis {_ current 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]} {
if {$new ne {}} {
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 {}] 2 2 $new]
dict set map .basis $body
namespace ensemble configure $_ -map $map
return [lindex $args 0]
} elseif {[llength $args] == 0} {
return [lindex $body 2]
} else {
error [list {wrong number of args} [llength $args]]
}
}
proc .chain {_ methodname} {
puts [list doof $_]
set map [namespace ensemble configure $_ -map]
dict update map $methodname entry {
set entry [dict get $map $methodname]
puts [list $_ dwork $methodname $entry]
set basis [$_ .state get method $methodname basis]
if {$basis eq {}} {
lassign [$_ .next $methodname] basis unused
if {$basis eq {}} {
error [list {no super} $methodname]
}
}
set index [lindex [$_ .state get method $methodname self] 0]
set entry [linsert $entry[set entry {}] $index $basis]
puts [list hubba $entry]
}
namespace ensemble configure $_ -map $map
}
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]
}
set map [namespace ensemble configure $_ -map]
uplevel 1 [list [namespace which duplicate] $_ $to]
set to [uplevel 1 [list [namespace which ensemble] duplicate $_ $to]]
set map [namespace ensemble configure $to -map]
$to .basis [$_ .basis]
set map [namespace ensemble configure $to -map]
set ns [namespace ensemble configure $to -namespace]
@makemy@
$to .disposal [lindex [$_ .disposal] 0]
set to [$to .cloned]
return $to
}
proc .cloned _ {
return $_
}
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]} {
set seen {}
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
}
# for better performance avoid doing this check too early
if {$basis in $seen} break
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.
}
}
}
}
try [string map [list @resolve@ {
set name0 [lindex $name 0]
set targs [lrange $name[set name {}] 1 end]
if {[llength $args] == 0} {
set target0 $name0
if {[string match ::* $target0]} {
set name0 [namespace tail $target0]
}
} else {
set args [lassign $args[set args {}] target0]
}
set resolved [uplevel 1 [list $_ .resolve $target0]]
if {![llength $resolved]} {
error [list {no such routine} $name0]
}
lassign $resolved basis target
}] {
proc .method {_ name args} {
@resolve@
if {[$_ .state exists routine $name0]} {
$_ .state delete routine $name0
}
$_ .state set method $name0 basis $basis
if {$name0 eq {.state}} {
set state [$_ .state get]
set args [lreplace $args[set args {}] 0 0 $state[set state {}]]
}
if {$basis eq {}} {
$_ .state set method $name0 self [expr {[llength $target] + [llength $targs]}]
set tlist [list {*}$target {*}$targs $_ {*}$args]
} else {
if {[llength $targs]} {
error [list {can not curry an inherited method}
}
set indices [$basis .state get method $name0 self]
$_ .state set method $name0 self $indices
foreach index $indices {
set target [lreplace $target[set target {}] $index $index $_]
}
set tlist [list {*}$target {*}$args]
}
set map [namespace ensemble configure $_ -map]
dict set map $name0 $tlist
namespace ensemble configure $_ -map $map
return
}
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 {_ name args} {
@resolve@
if {[$_ .state exists method $name0]} {
$_ .state delete method $name0
}
$_ .state set routine $name0 basis $basis
set map [namespace ensemble configure $_ -map]
dict set map $name0 [list $target {*}$targs {*}$args]
namespace ensemble configure $_ -map $map
return
}
}]
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
}
proc .resolve {_ name} {
if {[$_ .state exists plugged]} {
set context [$_ .state get plugged]
} else {
set context $_
}
if {[string match ::* $name]} {
set found $name
return [list {} $found]
} else {
set normalized [normalize $name [
uplevel 1 {namespace current}]]
set found [namespace which $normalized]
if {$found ne {}} {
return [list {} $found]
}
$_ .next $name
}
}
variable doc::next {
description {
look up a method in basis shelves
}
}
proc .next {_ name} {
set basis [$_ .basis]
set seen {}
while {$basis ne {}} {
set map [namespace ensemble configure $basis -map]
if {[dict exists $map $name]} {
set found [dict get $map $name]
return [list $basis $found]
} else {
lappend seen $basis
set basis [$basis .basis]
if {$basis in $seen} {
error [list {circular shelves} $basis]
}
}
}
}
proc .site {_} {
lindex [.state $_ get site [.state $_ get lastmethod]]
}
proc .switch {_ cmd args} {
if {$cmd eq {shelf}} {
set args [lassign $args[set args {}] shelf cmd]
} else {
# -1 for switch and -1 for the call to .state
set shelf [.state $_ get site [.state $_ get lastmethod]]
set shelf [$shelf .basis]
}
set script [resolve $_ $shelf $cmd]
if {$script eq {}} {
error [list {uknown command} $cmd]
}
tailcall {*}$script {*}$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 to stop {ns ensemble duplicate} from duplicating the namespace.
# 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 rewrite 0]]
set map [namespace ensemble configure $to -map]
set routines [dict keys [$_ .state get routine]]
foreach routine $routines {
dict set map $routine [dict get $map $routine]
}
set methodmap [$_ .state get method]
dict for {name cinfo} $methodmap {
dict with cinfo {
set cmd [dict get $map $name]
foreach idx $self {
set cmd [lreplace $cmd[set cmd {}] $idx $idx $to]
}
}
dict set map $name $cmd
}
namespace ensemble configure $to -map $map
$to .basis $_
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 export *
namespace ensemble create -parameters {_ state} -map {
exists exists get get replace replace set .set
}
proc replace {_ dummy value} {
set map [namespace ensemble configure $_ -map]
dict update map .state state {
set state [lreplace $state[set state {}] 2 2 $value]
}
namespace ensemble configure $_ -map $map
return $value
}
proc exists {_ dummy args} {
set map [namespace ensemble configure $_ -map]
dict update map .state state {
set info [lindex $state 2]
}
return [dict exists $info {*}$args]
}
proc get {_ dummy args} {
set map [namespace ensemble configure $_ -map]
dict update map .state state {
set info [lindex $state 2]
}
if {[llength $args]} {
return [dict get $info {*}$args]
} else {
return $info
}
}
proc .set {_ dummy args} {
set map [namespace ensemble configure $_ -map]
dict update map .state state {
set info [lindex $state 2]
dict set info {*}$args
set state [lreplace $state[set state {}] 2 2 $info]
}
namespace ensemble configure $_ -map $map
set res [get $_ {} {*}[lrange $args 0 end-1]]
return $res
}
}
proc .unknown {_ routine args} {
error [list {unknown command} $routine for $_ {should be one of} [
.routines $_]]
}
proc .wrap {_ prefix args} {
lassign $prefix routine
if {![string match ::* $routine]} {
lset prefix 0 [uplevel 1 [list [namespace which normalize] $routine]]
}
$_ .method .unknown [list ::apply [list {_ args} {
::tailcall {*}[$_ .wrapped] {*}$args
}]]
$_ .routine .wrapped ::lindex $prefix
}
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} \
@self@ {$_} \
@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 [
{
}
]
}
args {
_ {}
}
}
proc init {_ args} {
namespace upvar $_ doc::init doc
if {[info exists doc]} {
checkargs $doc {*}$args
} else {
checkargs [$_ $ doc::init] {*}$args
}
return $_
}
# bootstrap
::apply [list _ {
namespace ensemble configure [namespace current] -map [list \
.basis [list .basis [namespace current] {}] \
.namespace [list .namespace [namespace current]] \
.resolve [list .resolve [namespace current]] \
.state [list .state [namespace current] {}]
]
$_ .state set basis {}
$_ .state set disposal {}
$_ .state set method {}
$_ .state set routine {}
.method $_ .method
$_ .method .basis .basis {}
$_ .method .state .state [$_ .state get]
foreach name {
.resolve
} {
$_ .method $name
}
# Bootstrap the first shelf . Assume that the name of the current namespace
# is the name of the ensembles .
foreach procname {
$ $.exists $.locate .~ .attribute .chain .clone .cloned
.configure .disposal .eject .eval .inject .invoke .next .plugin
.renamed .routine .routines .site .spawn .spawned .unknown .vars .wrap
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 $procname
}
$_ .method .plug [list [yclprefix]::shelf::util::.nsshelf_plug] [
list [namespace current]]
set map [namespace ensemble configure $_ -map]
$_ .method .switch
$_ .method .apply
$_ .method .namespace
$_ .disposal .~
} [namespace current]] [namespace current]
set map [namespace ensemble configure [namespace current] -map]
interp alias {} [namespace current]::.my {} ::apply [list {_ args} {
::tailcall $_ {*}$args
} [namespace current]] [namespace current]
}] [namespace current]]