#! /bin/env tclsh
package require {ycl string}
namespace import [yclprefix]::string::dedent
package require {ycl ns}
namespace import [yclprefix]::ns::normalize
package require tdom
dom setNameCheck false
dom setObjectCommands token
namespace ensemble create -command instance -parameters item
variable doc::env {
definitions
dictionary list
like a Tcl dictionary
but all items are processed even if keys are redundant
vdict
a dictionary formed from contents of an item and analagous items in its containers
items closer to the current location occur later so they take precedence
location
a position of an item in the structure
description
this system implements an abstract data type
item
has
system identifier
a unique value in the system
name
container
an item
or nothing
value
contents
a sequence of items
when viewed downwards
toward the tips of the branches
acts as multidimensional array
when viewed upwards
in the direction of containers
toward the beginning
acts as a set of environments
items in enclosing environments override those in containing
environments
direct containers are excluded
commands typically produce item names
command annotations
^
look into containers
$
produce values
&
produce system identifiers
}
variable doc::$ {
description
step to some set of items and produce the values of those items
arguments
args
a location to pivot to first
}
proc $ {current args} {
variable cache
variable values
::set items [$& $current {*}$args]
# when there are no args, the result is a dictionary
if {![llength $args]} {
::set res {}
while {[llength $items]} {
::set items [lassign $items[::set items {}] item]
lappend res [name $item] [value $item]
}
return $res
}
if {![llength $items]} {
error [::list {no such value} $args for $item]
} elseif {[llength $items] == 1} {
return [value [lindex $items 0]]
} else {
::set res {}
while {[llength $items]} {
::set items [lassign $items[::set items {}] item]
lappend res [value $item]
}
return $res
}
}
variable doc::get ${doc::$}
interp alias {} [namespace current]::get {} [namespace current]::$
proc $^ {current args} {
::set res [$^! $current {*}$args]
if {[llength $res] > 1} {
error [::list {multiple results}]
}
return [lindex $res 0]
}
variable doc::$^ {
description
like $^& but produce a value
}
proc $^! {current args} {
variable values
lmap item [$^& $current {*}$args] {
value $item
if {[catch {value $item} res]} {
error [::list {no such value}]
} else {
lindex $res
}
}
}
interp alias {} [namespace current]::get^ {} [namespace current]::$^
variable doc::$^& {
description
look up an item
by
name
in
either
the current item
or
one of its containers
and produce
if it exists
its system identifier
otherwise
the empty string
}
proc $^& {current args} {
::set item [which $current {*}$args]
return $item
}
interp alias {} [namespace current]::get^& {} [namespace current]::$^&
variable doc::$& {
description
step to some set of items
arguments
args
steps to pivot through first
}
proc $& {item args} {
if {[llength $args]} {
::set items [pivot $item {*}$args]
if {![llength $items]} {
error [::list {does not exist} $args from [location $item]]
}
return $items
}
list& $item
}
interp alias {} [namespace current]::get& {} [namespace current]::$&
variable doc::adict^ {
description
attribute dictionary
produce an vdict composed of items in the locations having the
given path relative to the current item or its containers
}
proc adict^ {current args} {
::set res {}
foreach item [whichm $current {*}$args] {
# the local [dict]
lappend res {*}[dict $item]
}
return $res
}
proc append {current args} {
lassign [lrange $args end-1 end] name value
if {[llength $args] > 2} {
::set current [create $current {*}[lrange $args[::set args {}] 0 end-2]]
}
::set res $current
::set res [domNode $current appendChild [setval [domDoc [
domNode $current ownerDocument] createElement $name] $value]]
return $res
}
variable doc::appendm {
description
append multiple new items to the contents of the current item
arguments
last argument
a dictionary list providing the names and values for new items
preceding arguments
a location to pivot to first
creating containers as needed
}
proc appendm {current args} {
::set items [lindex $args end]
if {[llength $args] > 1} {
::set current [create $current {*}[lrange $args[::set args {}] 0 end-1]]
}
foreach {name value} $items[::set items {}] {
::set res [domNode $current appendChild [setval [domDoc [
domNode $current ownerDocument] createElement $name] $value]]
}
return $current
}
variable doc::as {
description
[pivot] to another location and apply a command
}
proc as {current location name args} {
as& $current [pivot $current {*}$location] $name {*}$args
}
variable doc::as& {
description
apply a command on another item
}
proc as& {current item name args} {
$name $item {*}$args
}
proc as^ {current path name args} {
::set cursor [which $current {*}$path]
if {![llength $cursor]} {
error [::list {no such path} $path]
}
as& $current $cursor $name {*}$args
}
variable doc::command {
description
create a command to represent an item
}
proc command {current name} {
::set name [uplevel 1 [::list [namespace which normalize] $name]]
interp alias {} $name {} [namespace current] instance $current
}
variable doc::container {
description
get the container of the current item
}
proc container current {
domNode $current parentNode
}
interp alias {} [namespace current]::.. {} [namespace current]::container
variable doc::containers {
description
containers of the current item
excluding the top container
}
proc containers current {
variable cache
domNode $current selectNodes -cache $cache {ancestor::*}
}
variable doc::create {
description
create a new item
arguments
args
a location to pivot to
creating items as necessary
}
proc create {current args} {
lappend cursors $current
foreach step $args {
::set new {}
foreach cursor $cursors {
# uplevel because [step] might need access to the calling
# environment
lappend new {*}[uplevel 1 [
::list [namespace which step] $cursor $step 1]]
}
::set cursors $new
}
return $cursors
}
variable doc::ddict {
description {
like [dict] but descend into items that have contents to build nested
dictionaries
}
}
proc ddict {current args} {
::set res {}
if {[llength $args]} {
::set current [pivot $current[::set current {}] {*}$args]
}
foreach item [list& $current] {
::set res2 [ddict $item]
if {[llength $res2]} {
::dict set res [name $item] $res2
} else {
::dict set res [name $item] [value $item]
}
}
return $res
}
variable doc::delete {
description
delete an item
}
proc delete current {
variable values
foreach item [domNode $current childNodes] {
delete $item
}
# this deletes the dom node
array unset values $current
}
variable doc::dict {
description
produce a dictionary from the contents of an item
arguments
args
see [list]
}
proc dict {current args} {
if {[llength $args]} {
::set current [pivot $current[::set current {}] {*}$args]
}
::set res {}
items dict [list& $current]
}
variable doc::dict^ {
description
produce a dictionary from the contents of the closest location matching
the given path
the containers of the current item themselves are excluded
arguments
args
a location to pivot to first
result
an vdict
}
proc dict^ {current args} {
items dict [list^& $current {*}$args]
}
variable doc::epsilon {
description
select the
container of all containers
items are the first containers
}
proc epsilon current {
return [domNode $current root]
}
proc exists {current args} {
expr {![catch [::list pivot $current {*}$args]]}
}
proc exists^ {current args} {
expr {[which $current {*}$args] ne {}}
}
variable doc::id {
description
retrieve a system identifier for the item
}
proc id current {
return $current
}
proc item {current name} {
variable cache
::set res [domNode $current selectNodes -cache $cache \
{*[name() = $name][last()]}]
if {![llength $res]} {
error [::list {no such item} $name in [location $current]] {} [::list NOEXIST]
}
return $res
}
variable doc::list {
description
produce the contents of the current item
arguments
args
a location to pivot to first
}
proc list {current args} {
variable cache
::set res {}
foreach item [list& $current {*}$args] {
lappend res [name $item]
}
return $res
}
proc list$ {current args} {
variable cache
::set res {}
foreach item [list& $current {*}$args] {
lappend res [value $item]
}
return $res
}
proc list& {current args} {
variable cache
if {[llength $args]} {
::set current [pivot $current {*}$args]
}
domNode $current selectNodes -cache $cache *
}
variable doc::list {
description
produce a list from the contents of the current item and its containers
}
proc list^& {current args} {
variable cache
::set res [::dict create]
if {[llength $args]} {
foreach arg $args {
::set arg[incr i] $arg
lappend pred "name() = \$arg$i"
}
::set pred \[[join $pred { or }]\]
} else {
::set pred {}
}
::set query [string map [::list @pred@ $pred] \
{*@pred@|ancestor-or-self::*/preceding-sibling::*@pred@|ancestor-or-self::*/following-sibling::*@pred@}]
domNode $current selectNodes -cache $cache $query
}
proc location {current args} {
if {[llength $args] == 1} {
::set env1 [lindex $args 0]
::set p1 [::list {*}[containers $current] $current]
::set p2 [::list {*}[containers $env1] $env1]
::set i 0
foreach n1 $p1 n2 $p2 {
if {$n1 ne $n2} break
::set common $n1
incr i
}
::list {*}[lrepeat [expr {[llength $p1] - $i}] ..] {*}[
lmap item [lrange $p2 $i end] {
name $item
}
]
} elseif {![llength $args]} {
::list {*}[lmap item [containers $current] {
name $item
}] [name $current]
} else {
error [::list {wrong # args}]
}
}
variable doc::mv {
description
move the item
produce the new container
}
proc mv {item args} {
::set container [pivot {*}$args]
mv& $item $container
}
proc mv& {item target} {
domNode $target appendChild $item
return $target
}
variable doc::name {
description
retrieve or set the name of an item
}
proc name {current args} {
if {[llength $args] == 1} {
domDoc [domNode $current ownerDocument] renameNode $current [lindex $args 0]
}
domNode $current nodeName
}
variable doc::new {
description
create a new environment in a new ecosystem
first argument
list of
name
value
optional
remaining arguments
passed to [setm]
}
proc new args {
lassign [lindex $args 0] name value
::set args [lreplace $args[::set args {}] 0 0]
::set doc [dom createDocument $name]
::set current [domDoc $doc documentElement]
setval $current $value
if {[llength $args]} {
setm $current $args
}
return $current
}
variable doc::items {
description
commands that process lists of items
}
namespace eval items {
interp alias {} [namespace current]::value {} [namespace parent]::value
namespace import [namespace parent]::name
namespace export *
namespace ensemble create
proc dict items {
# assuming a top-down search , the nearest matches in the tree are
# to the end of the list , and will therefore override the
# earlier matches when this result is treated as a dictionary .
::set res {}
foreach item $items[::set items {}] {
lappend res [name $item] [value $item]
}
return $res
}
}
proc pivot {current args} {
variable cache
::set path {}
::set res {}
lappend cursors $current
::set res [pivot! $current {*}$args]
if {[llength $res] > 1} {
error [list {multiple results}]
}
return [lindex $res 0]
}
proc pivot! {current args} {
variable cache
::set path {}
::set res {}
lappend cursors $current
foreach arg $args {
::set new {}
foreach current $cursors {
# uplevel because [step] might need access to the calling
# environment
lappend new {*}[uplevel 1 [::list [namespace which step] $current $arg]]
}
::set cursors $new[::set new {}]
}
return $cursors
}
proc pretty {current args} {
if {[llength $args] == 0} {
::set chan stdout
::set indent {}
} elseif {[llength $args] == 1} {
lassign $args chan
::set indent {}
} elseif {[llength $args] == 2} {
lassign $args chan indent
} elseif {[llength $args]} {
error [::list {wrong # args}]
}
puts $chan $indent[::list [name $current] [value $current]]
foreach current [list& $current] {
pretty $current $chan $indent\t
}
}
namespace eval scan {
interp alias {} [namespace current]::get {} [namespace parent]::get
interp alias {} [namespace current]::item {} [namespace parent]::item
interp alias {} [namespace current]::set {} [namespace parent]::set
namespace export *
namespace ensemble create -parameters current
proc dict {current dict} {
::dict for {key val} $dict {
if {[catch {::dict size $val}]} {
# not ::set
set $current [list . $key] $val
} else {
# not ::set
set $current [list . $key] {}
dict [item $current $key] $val
}
}
}
}
variable doc::serialize {
description
add values to the tdom structure for the environment
}
proc serialize current {
lappend queue $current
while {[llength $queue]} {
::set queue [lassign $queue[::set queue {}] current]
lappend queue {*}[list& $current]
strip $current
::set doc [domNode $current ownerDocument]
domDoc $doc createTextNode [value $current] textnode
domNode $current appendChild $textnode
}
return
}
variable doc::set {
in an environment
retrieve
store
values
the path-value pairs in $args
if one or more items having a specified name already exist
the new value is stored in the last item in the collection
location
a list of item names representing nested items
first word
.
The current environment
..
The containing environment
{}
The top container
If the number of words in $args is odd the first word is a location relative to
which all remaining locations are resolved
}
proc set {current args} {
if {[llength $args] < 2} {
return [$ $current {*}$args]
}
::set val [lindex $args end]
::set args [lrange $args[::set args {}] 0 end-1]
foreach env [create $current {*}$args] {
setval $env $val
}
return $val
}
proc setm {current args} {
variable cache
::set items [lindex $args end]
::set pivot [lrange $args[::set args {}] 0 end-1]
if {[llength $pivot]} {
::set cursors [create $current {*}$pivot]
} else {
lappend cursors $current
}
::set res {}
foreach {name value} $items {
foreach cursor $cursors {
foreach cursor2 [create $cursor [::list . $name]] {
lappend res $value
setval $cursor2 $value
}
}
}
return $res
}
proc setval {current value} {
variable values
#to do
# make sure tcl doesn't generate a string value here
if {$value ne {}} {
if {![info exists values($current)]} {
trace add variable values($current) unset [
::list ::apply [::list {current name1 name2 ops} {
domNode $current delete
} [namespace current]] $current]
}
::set values($current) $value
}
return $current
}
variable doc::step {
description
move from one point to zero or more other points
step
either
the name of an item
or
a list where the first character is one of
!
execute a command to which is appended the current step
.
the second item in the list is the name of the target
}
proc step {current step {create 0}} {
::set res {}
::set stepped 0
::set rest [lassign $step name]
if {[llength $step] > 1} {
::set specifier $name
::switch $specifier {
! {
#command
::set res [uplevel 1 [::list {*}$rest $current]]
return $res
return [uplevel 1 [::list {*}$rest $current]]
}
. {
# literal
::set name [lindex $rest 0]
}
= {
# expr
}
@ {
return [uplevel 1 [::list ::domNode $current selectNodes [concat $rest]]]
}
default {
error [::list {bad step} $step]
}
}
} else {
::switch $step {
.. {
::set new [container $current]
if {$new ne {}} {
return [::list $new]
::set current $new
}
}
}
}
if {!$stepped} {
try {lappend res [item $current $name]} trap NOEXIST {tres topts} {
if {$create} {
lappend res [domNode $current appendChild [setval [domDoc [
domNode $current ownerDocument] createElement $name] {}]]
} else {
return -options $topts $tres
}
}
}
return $res
}
variable doc::strip {
description
strip values from the tdom structure for the environment
}
proc strip current {
foreach item [list& $current] {
::set type [domNode $item nodeType]
::switch $type {
TEXT_NODE {
domNode $item delete
}
}
}
}
variable doc::top {
description
select the top item
not necessarily the top container
}
proc top current {
lindex [domNode $current selectNodes {ancestor-or-self::*}] 0
}
variable doc::tree {
description {
produce a list whose elements are
the name of the environment
the value of the environment
a list of the same results for each item
}
}
proc tree {current args} {
::set res {}
if {[llength $args]} {
::set current [pivot $current {*}$args]
}
foreach item [list& $current] {
lappend res [::list [name $item] [value $item] [tree $item]]
}
return $res
}
variable doc::unset {
description
unset a named item in an environment
}
proc unset {current args} {
variable values
if {[llength $args]} {
::set item [pivot $current {*}$args]
domNode $item delete
# this deletes the dom node
array unset values $item
}
return
}
variable doc::value {
description
return the value of an item
}
proc value item {
variable values
if {[info exists values($item)]} {
return $values($item)
} else {
return {}
}
}
variable doc::var {
description
return
the name of a variable
for the corresponding name
in an environment
should not be renamed
}
proc var {current args} {
variable values
if {[llength $args]} {
::set current [pivot $current {*}$args]
}
return [namespace current]::values($current)
}
variable doc::view {
description
like view&
but return values instead of system identifiers
}
proc view {current args} {
variable values
items dict [view& $current {*}$args]
}
variable doc::view& {
description
Pivot to a specified container and list the items under a specified
item, also the items of any containers in any parents of the current
container that have the same name as the specified container
If no item is specified
use the name of the current container as the item
and pivot to the parent container
closer keys appear later so that they override earlier keys in [dict]
operations
}
proc view& {current args} {
variable cache
if {[llength $args]} {
::set name [lindex $args end]
if {[llength $args] > 1} {
::set current [pivot $current {*}[lrange $args 0 end-1]]
}
} else {
::set name [name $current]
}
::set query {ancestor-or-self::*/child::%name/*}
foreach current1 $current {
::set found [domNode $current selectNodes -cache $cache $query]
}
return $found
}
variable doc::which {
description {
Determine which environment a variable is located in
}
}
proc which {current args} {
variable cache
if {![llength $args]} {
return $current
}
::set args [lassign $args[::set args {}] name]
lappend qparts {ancestor-or-self::*/child::*[name() = $name][last()]}
foreach arg $args {
::set qpart {}
::set vname name[incr i]
::set $vname $arg
::append qpart {child::*[name() = $} $vname {][last()]}
lappend qparts $qpart
}
# the last item in the list is "closest".
::set query ([join $qparts /])\[last()]
::set found [domNode $current selectNodes -cache $cache $query]
if {![info exists name]} {
set name {}
}
# only one item in the list
return [lindex $found 0]
}
proc whichm {current args} {
variable cache
::set res [::dict create]
if {[llength $args]} {
foreach arg $args {
::set arg[incr i] $arg
lappend path "%arg$i"
}
::set path [join $path[::set path {}] /]
}
::set query [string map [::list @path@ $path] {ancestor-or-self::*/@path@}]
::set res [domNode $current selectNodes -cache $cache $query]
domNode $current selectNodes -cache $cache $query
}
variable values
array set values {}
# Determine whether the -cache option is usable, i.e., whether tdom features
# the functionality implemented in commit
# 6d44c5b09265f523771a7a04079c75c8dcf3f31e, 2017-06-16 .
# . See ticket 97c0994ae4aa90531b2929e2d64189ccaec444ff for a patch .
apply [::list args {
variable cache 0
::set doc [dom createDocument root]
::set root [domDoc $doc documentElement]
::set item [domDoc $doc createElement one]
domNode $root appendChild $item
::set item [domDoc $doc createElement two]
domNode $root appendChild $item
::set name one
::set res [domNode $root selectNodes -cache 1 {*[name() = $name]}]
::set name two
::set res [domNode $root selectNodes -cache 1 {*[name() = $name]}]
::set nodename [domNode $res nodeName]
if {$nodename eq {two}} {
::set cache 1
}
::set msg [dedent "
ycl env
dom
-cache $cache
"
]
puts stderr $msg
domDoc $doc delete
} [namespace current]]