#! bin/env tclsh
#things I came across while writing this code...
#http://wiki.tcl.tk/22051
#http://steve-yegge.blogspot.com/2008/10/universal-design-pattern.html
#http://www.selflanguage.org
#http://people.fishpool.fi/~setok/proj/Selfish/
package require ycl::exo
namespace import [yclprefix]::exo::exo
if {0} {
#! exo
' {Shellfysh is a framework for context-oriented computing. In
programming, layers of context are found everywhere. In a graphical
layout, visual elements are composed in layers so that each layer can be
positioned behind or in front of other visual elements. In object-oriented
programming, layers of context are used to model instances, classes, and
class hierarchies. In XML, layers of context are implied by the
hierarchical node structure. In CSS layers of context help to organize the
visual stylings of an HTML document. In some languages, e.g. Javascript
or self, layers of context are used in a system of objects and prototypes.
In functional programming languages, closures and other constructs make use
of layers of context. Steve Yegge calls these layers of context "the
universal design pattern"}
' {The main idea with layers of context is that when looking up a variable
or procedure, a layer will search itself and then its enclosing layers.
Thus, the enclosing layers provide context for the current layer. The
programmer can use these layers to organize code and data.}
' {In Shellfysh, a layer of context is implemented as a TCL namespace that
has certain properties:}
outline {
' {a parent layer of context}
null
' {attributes (variables)}
' looked for first in the layer, then in the context
' procedures
' {looked for first in the layer then in the context (via
[namespace path]}
' {mapped procedure (using namespace ensembles)}
outline {
' {copied for clones}
null
' {looked up in context (via namespace ensemble uknown) for derivates}
' {If not found in layer or context, looked up in the
ycl::context namespace}
}
' {method (using namespace ensembles)}
' {like mapped procedures, but the first argument to the procedure is
the name of the layer itself}
' {regular procedures}
' {normal procedures in the namespace of the layer}
' {implementation definitions}
def {
' layer
' {A namespace and a namespace ensemble such as that as
that returned by [context].}
}
def {
' context
' {A layer which has been used as a template to create
other layers. Any layer could be used as a context.}
}
}
title {' creating a new layer} {
syntax tcl {
context animal1
set animal1 [context]
set animal1 [context animal1]
}
}
title {' cloning a layer} {
syntax tcl {
animal1 clone animal2
}
}
title {' deriving a layer} {
syntax tcl {
animal1 derive animal3
}
}
title {' attribute assignment} {
syntax tcl {
animal1 $ name Rover
#equivalent
animal1 var name Rover
}
}
title {' attribute lookup} {
syntax tcl {
animal1 $ name
}
' or
syntax tcl {
animal1 var name
}
' {If an attribute does not exist in a layer, the attribute is looked up in
the layer's context.}
}
title {attribute removal} {[syntax tcl {
animal1 unset name
}]
Attribute is only removed from the current layer
}
def {' assigning a default value for missing attributes} {
syntax tcl {
context access_control
access_control configure default var [list read write]
}
}
def {' setting an array} {
syntax tcl {
animal1 $ preferences(cats) plump
animal1 eval {
array set animal1(cats) plump
}
}
}
def {' look up up an array value} {
syntax tcl {
animal1 $ preferences(cats)
animal1 array preferences cats
}
}
def {' look up an entire array} {
syntax tcl {
animal1 array preferences
}
}
def {' further information about an attribute, including which object it
actually resides in} {
tcl syntax {
animal1 info preferences(cats)
}
}
def {' creating a procedure (regular, not a mapped procedure)} {
tcl syntax {
animal1 eval {
proc count {} {
variable count
incr count
}
}
}
}
def {' creating a mapped procedure} {
tcl syntax {
proc count {} {
variable count
incr count
}
animal1 map count
}
}
' {Use a mapped procedure to make procedures in other namespaces available
to the current layer. The procedure underlying a mapped procedure can be
in an arbitray namespace, so its effects might be slightly different. In
the example above, [variable count] refers to the namespace that the count
procedure is currently in, and thus the $count that is incremented is not
necessarily located within the layer.}
' {A mapped method is a mapped procedure that gets the name of its layer as
its first argument (analogous to "self" in other programming paradigms).
When a mapped method is cloned or derived from, it is adjusted so that the
first argument is the new layer. To make a method:}
syntax tcl {
proc fly {id} {
return "$id is flying!"
}
animal1 method fly
}
' {Thereafter, you use it like this:}
syntax tcl {
animal1 fly
}
' {To map the method to a different name:}
syntax tcl {
animal1 method flutter fly
}
' {In which case, the usage would be:}
syntax tcl {
animal1 flutter
}
' {A namespace ensemble (or nested chain of namespace ensembles) may be
used as a method as long as the subcommand at the end of the chain takes
the layer name as its first argument.}
. {Cloning a layer makes a new layer that contains copies of all the
procedures and variables of the original layer. The [namespace ensemble
-map] of the original layer is copied, and for all methods found in the
map, the new layer replaces the old layer in the method calls. An example
of clone:}
syntax tcl {
animal1 clone animal2
}
' {Deriving is different from cloning. Deriving also creates a new layer,
but whereas cloning creates copies of the elements of the original context,
deriving just provides a mechanism to look up those elements in its
context. To derive a new object:}
syntax tcl {
animal2 derive animal3
}
' {Procedures that are specifically written to be used as methods will
generally behave as expected when used as such. With derive, though, there
are more caveats to mapped procedures (not methods). Consider this
example:}
syntax tcl {
animal3 count
}
' {Recall from above that the count procedure is not a method, and is
located in the namespace of animal2, so "child count" actually increments
the animal2::count! Beware!}
' {When using [variable] in a method, it is usually best to ensure that it
is used with the fully-qualified name of the layer.}
' {It is possible to configure a layer not to search its enclosing layers when
resolving procedures:}
syntax tcl {
animal3 configure breakup procs
}
' {To configure a layer not to search for the variables (or arrays)
"spouse" or "license" variable in its contexts:}
syntax tcl {
animal3 configure block [list spouse license]
}
' {To block an individual array key:}
syntax tcl {
animal3 configure block preferences(music)
}
' {To see a name-value map of blocked variable names:}
syntax tcl {
animal3 configure blocked
}
' {To unblock variable names:}
syntax tcl {
animal3 configure block [list]
}
' {To see the context of an layer:}
syntax tcl {
animal3 context
}
' {To change the context of animal3 to animal1:}
syntax tcl {
animal3 context animal1
}
' {To delete animal3:}
syntax tcl {
animal3 bye
}
' {A layer naturally features copy-on-write semantics for variables,
procedures, mapped procedure and methods. Of course, anything done via an
layer's "eval" method can also directly affect the namespace of the layer.}
' {To change (reparent) the context of a layer:}
animal3 update animal1 context
}
package require ycl::context::etc
variable etc [yclprefix]::context::etc
interp alias {} [namespace current] {} [namespace current]::context
#the name of the meta-layer of each layer
namespace upvar $etc META META
namespace upvar $etc BLOCK BLOCK
namespace upvar $etc CONFIGURE CONFIGURE
namespace upvar $etc RETURN RETURN
namespace upvar $etc INFO_VAR_BLOCKED INFO_VAR_BLOCKED
namespace upvar $etc INFO_VAR_NAME INFO_VAR_NAME
namespace upvar $etc INFO_VAR_NS INFO_VAR_NS
namespace upvar $etc INFO_VAR_ERROR INFO_VAR_ERROR
namespace upvar $etc INFO_VAR_VAL INFO_VAR_VAL
namespace upvar $etc VAR_DEFAULT VAR_DEFAULT
variable UPDATE [list context vars procs map path]
package require ycl 0.1
package require ycl::ns
variable ns [yclprefix]::ns
package require ycl::list
variable list [yclprefix]::list
package require ycl::context::configure
variable contextConfigure [yclprefix]::context::configure
package require ycl::context::info
variable info [yclprefix]::context::info
namespace export clone context derive
namespace import ${list}::rlindex
proc array+ {id name} {
#if the array itself is blocked just return ${id}::$array
if {[dict exists [$id configure blocked] $name]} {
return [array get ${id}::$name]
}
#first, merge all upstream arrays
set res [dict create]
foreach context [$id info contexts] {
if {[array exists ${context}::$name]} {
set res [dict merge [array get ${context}::$name] $res[set res {}]]
}
}
#all other local variables *must not* begin with "."!
array set .$name $res
#remove all blocked array variables
#the case of entire blocked array was already handled above
set blocked [dict keys [$id configure blocked] ${name}(*]
foreach block $blocked {
if {[::info exists .${block}]} {
unset .${block}
}
}
set res [array get .${name}]
set res [dict merge $res [array get ${id}::$name]]
return $res
}
proc arrays+ {id name} {
set res [list]
if {[array exists ${id}::$name]} {
lappend res ${id}::$name
}
foreach id [$id info contexts] {
if {[array exists ${id}::$name]} {
lappend res ${id}::$name
}
}
return $res
}
#proc: bye:
#argument: id: namespace to delete
#value: result of [namespace delete]
#effect: $id is deleted
proc bye+ {id} {
namespace delete $id
}
proc clone+ {id args} {
variable META
variable ns
set argl [llength $args]
set args [lassign $args newns]
#using the new command not right because it had the potential to
#override customized methods of the user.
#set new [new $newns]
set new [${ns}::ensemble [uplevel namespace current] $newns]
if {[string match ${id}::* $new]} {
return -code error "a clone can not be created within the cloned context: $new is in $id"
}
namespace ensemble configure $new {*}[dict remove \
[namespace ensemble configure $id] -namespace]
#variables and procedures
${ns}::copyvars $id $new
${ns}::copyprocs $id $new
#copy the meta namespace
${ns}::copyvars ${id}::$META ${new}::$META
${ns}::copyprocs ${id}::$META ${new}::$META
#ensemble map
if {[namespace ensemble exists $id]} {
remap $id $new
}
#adjust namespace path
namespace eval $new [list namespace path [namespace eval $id namespace path]]
#clone all children recursively, except the META namespace
foreach child [namespace children $id] {
set basename [namespace tail $child]
if {![string equal $basename $META]} {
clone+ $child ${new}::${basename}
}
}
#reproduce traces
foreach opname [list command execution variable] {
set traces [trace info $opname $id]
foreach trace $traces {
trace add $opname $new [lindex $trace 0] [lindex $trace 1]
}
}
set new
}
# get or set object context
proc context+ {id args} {
variable META
variable ns
if {[llength $args]} {
set context [lindex $args 0]
set context [${ns}::nsnormalize $context $id]
return [namespace eval ${id}::$META [list variable context $context]]
}
if {![namespace exists $id]} {
return -code error "object does not exist: $id"
}
if {![namespace exists ${id}::$META]} {
return -code error "malformed object: $id"
}
if {[namespace eval ${id}::$META info exists context]} {
return [namespace eval ${id}::$META set context]
}
return -code error "no context found for object: $id"
}
proc derive+ {id {newns {}} } {
variable META
variable ns
set callingspace [uplevel 1 [list namespace current]]
set new [${ns}::ensemble $callingspace $newns]
namespace ensemble configure $new \
-unknown [namespace current]::unknown_method
namespace eval $new [list namespace path [ \
list $id {*}[namespace eval $id namespace path]]]
[namespace current]::context+ $new $id
#this was a bad idea, right? right? 2012-09
#foreach child [namespace children $id] {
# set basename [namespace tail $child]
# if {![string equal $basename $META]} {
# derive+ $child ${new}::[namespace tail $child]
# }
#}
#no remapping in derived layers
#remap $id $new
return $new
}
proc dict+ {id name} {
if {[$id eval [list info exists $name]]} {
set res [$id $ $name]
set found 1
} else {
set res [dict create]
set found 0
}
foreach context [$id info contexts] {
set found 1
set res [dict merge [$context $ $name] $res[set res {}]]
}
if {$found} {
return $res
} else {
return -code error "can't read \"$name\": no such variable"
}
}
proc eval+ {id args} {
tailcall namespace eval $id {*}$args
}
#NAME
# method+
#USAGE
# method+ NAMESPACE TARGET
# method+ NAMESPACE NAME TARGET [ARG...]
#DESCRIPTION
# TARGET the name of a procedure which will be set as the new method
# if NAME is not provided, it will be derived from the last element of TARGET
# NAMESPACE will be inserted as the first argument to TARGET
# each ARG will be set as an additional argument to TARGET
#VALUE: the namespace ensemble map for NAMESPACE
proc method+ {id name args} {
variable META
variable ns
#there are no out-of-band values available, so use args instead
#of a default value
if {[llength $args]== 0} {
set target $name
} else {
set args [lassign $args target]
}
set target [${ns}::nsnormalize $target [uplevel 1 namespace current]]
set name [namespace tail $name]
#set map [${ns}::map $id $name $target $id {*}$args]
set map [${ns}::map $id $name [namespace current]::subcommand+ $id $target {*}$args]
namespace eval ${id}::$META [list dict set map $name type method]
return $map
}
proc methods+ {id pattern} {
foreach name [::info commands $pattern] {
$id method [namespace tail $name] $name
}
}
proc subcommand+ {id args} {
set cmdpath [list [lindex $args 0]]
set args [lrange $args[unset args] 1 end]
#handle nested ensembles
foreach arg $args {
if {[llength [::info commands [join [list {*}$cmdpath $arg] ::]]]} {
lappend cmdpath $arg
set args [lreplace $args[unset args] 0 0]
} else {
break
}
}
set cmdpath [join $cmdpath[unset cmdpath] :: ]
set args [linsert $args[unset args] 0 $id]
::tailcall $cmdpath {*}$args
}
proc unset+ {id args} {
foreach name $args {
unset ${id}::$name
}
}
proc update+ { id from {what {}} } {
variable UPDATE
variable ns
set id [${ns}::nsnormalize $id [uplevel 1 namespace current]]
set from [${ns}::nsnormalize $from [uplevel 1 namespace current]]
set things [dict create]
set unknown [list]
if {[string equal $what {}]} {
foreach item $UPDATE {
dict set things $item 1
}
} else {
foreach nowwhat $what {
if {$nowwhat in $UPDATE} {
dict set things $nowwhat 1
} else {
set nowwhat [regsub {^no} $nowwhat {}]
if {$nowwhat in $UPDATE} {
dict unset things $nowwhat
} else {
lappend unknown $nowwhat
}
}
}
}
if {[llength $unknown]} {
return -code error \
"unknown items: $unknown. Should be one of $UPDATE"
}
foreach thing [dict keys $things] {
switch $thing {
context {
context+ $id $from
} vars {
${ns}::copyvars $from $id
} procs {
${ns}::copyprocs $from $id
} map {
map_update $id $from
} path {
set path [namespace eval $id namespace path ]
set path [linsert ${path}[set path {}] 0 $from ]
namespace eval $id [list namespace path $path]
}
}
}
}
interp alias {} [namespace current]::$ {} [namespace current]::var+
interp alias {} [namespace current]::$+ {} [namespace current]::var+
proc var+ {id args} {
variable INFO_VAR_BLOCKED
variable INFO_VAR_NAME
variable INFO_VAR_NS
variable INFO_VAR_VAL
set res [$id info var {*}$args]
if {
[dict get $res $INFO_VAR_NS] eq {} && \
[dict get $res $INFO_VAR_VAL] eq {}
} {
set var [dict get $res $INFO_VAR_NAME]
dict with res {
if {
[::info exists $INFO_VAR_BLOCKED] &&
[string length $INFO_VAR_BLOCKED] > 0
} {
set msg "variable \"[set $INFO_VAR_NAME]\" blocked in namespace [set $INFO_VAR_BLOCKED]"
} else {
set msg "var not found in context: $var"
}
}
return -code error $msg
} else {
return [dict get $res $INFO_VAR_VAL]
}
}
### "helper" functions ###
proc adjust_map {from to} {
variable META
set map [namespace ensemble configure $from -map]
set newmap [dict create]
foreach {key val} $map {
if {[llength $val] > 1} {
set arg1 [lindex $val 1]
set mapmeta [namespace eval ${from}::$META [list set map]]
#no need to adjust subcommands because subcommand+ takes care of that
if {[dict get $mapmeta $key type] eq "method"} {
#this is a method, and first argument should be adjusted
set val [lreplace $val[set val {}] 1 1 $to]
}
}
dict set newmap $key $val
}
return $newmap
}
proc check_option_onearg {idx argl name} {
if {[expr $argl -1] > $idx} {
return -code error "only 1 argument allowed after $name"
}
}
#remap methods from one namespace ensemble to another
proc remap {from to} {
set newmap [adjust_map $from $to]
namespace ensemble configure $to -map $newmap
return $newmap
}
proc map_update {id from} {
set newmap [adjust_map $from $id]
if {[namespace ensemble exists $id]} {
set nsmap [namespace ensemble configure $id -map]
} else {
set nsmap [dict create]
}
set nsmap [dict merge $nsmap $newmap]
namespace ensemble configure $id -map $nsmap
return $nsmap
}
#summary: look for methods, recursively, in a layer's contexts
#synopsis: unknown_method namespace subcommand ?args?
#description:
# $args contains any additional arguments the user added to the subcommand
proc unknown_method {id subcommand args} {
variable META
variable NS
set thisns {}
set context $id
#not needed (see comments below about not using args)
#set args [lreplace $args 0 0]
while 1 {
set context [[namespace current]::context+ $context]
if {$context eq $thisns} {
#reached the last context
break
}
set thisns $context
if {![namespace exists $context]} {
#the context must have been deleted
break
}
set map [namespace ensemble configure $context -map]
if {![dict exists $map $subcommand]} {
continue
}
set cmdargs [lassign [dict get $map $subcommand] cmd]
set mapmeta [namespace eval ${context}::$META [list set map]]
case [dict get $mapmeta $subcommand type] {
method {
#set cmdargs [lreplace $cmdargs 2 2 $id]
set cmdargs [lreplace $cmdargs 0 0 $id]
}
subcommand {
set cmdargs [lreplace $cmdargs 0 0 $id]
}
}
break
}
if {![::info exists cmd]} {
#finally, look for "builtin" methods
#allows builtin operations for an object even when its
#context has been deleted.
if {[llength [::info commands [namespace current]::${subcommand}+]]} {
set cmd [namespace current]::${subcommand}+
set cmdargs [list $id]
}
}
if {![::info exists cmd]} {
return -code error "not found in the context of $id: $subcommand"
}
#this is wrong because the "unknown" function should only return
#the command prefix
#return [list $cmd {*}$cmdargs {*}$args]
set res [list $cmd {*}$cmdargs]
return $res
}
#note: context constructor should not modify its meta namespace at all,
#because it could make derive and clone more error-prone.
#proc: context
#argument: id: the name of the namespace to be created
#value: a new context
#effect: namespace $id is created
proc context {{id {}}} {
variable CONFIGURE
variable META
variable ns
variable contextConfigure
variable info
if {$id eq {}} {
set callingspace [namespace current]
} else {
set callingspace [uplevel 1 namespace current]
}
set id [${ns}::ensemble $callingspace $id]
namespace ensemble configure $id -prefixes 0 \
-unknown [namespace current]::unknown_method
#see unknown_method for how these get resolved as "builtins"
#method+ $id [namespace current]::$
#method+ $id array [namespace current]::array+
#method+ $id arrays [namespace current]::arrays+
#method+ $id clone [namespace current]::clone+
#method+ $id bye [namespace current]::bye+
${ns}::map $id configure [namespace current]::subcommand+ $id ${contextConfigure}
namespace eval ${id}::$META [list dict set map configure type subcommand]
#method+ $id context [namespace current]::context+
#method+ $id derive [namespace current]::derive+
#method+ $id eval [namespace current]::eval+
${ns}::map $id info [namespace current]::subcommand+ $id ${info}
namespace eval ${id}::$META [list dict set map info type subcommand]
method+ $id map ${ns}::map
#method+ $id method [namespace current]::method+
#TODO: implement property
#method+ $id [namespace current]::property+ property
#method+ $id unset [namespace current]::unset+
#method+ $id var [namespace current]::var+
#method+ $id which [namespace current]::which+
#new layer gets itself for context
#don't use method dispatch here in clone
#$id context $id
context+ $id $id
return $id
}
# a "dynamic context, in the sense that methods and mapped commands are
# resolved at invocation time, rather than at declaration time
proc dcontext {{id {}}} {
}
return [yclprefix]::context