Index: library/lib/doc-tools.tcl
===================================================================
diff -u -r18ff1444fef5c209dfb40cf2ae694206c0d10309 -r26ce746b45449fbff64f88c6d9e9050a63b89449
--- library/lib/doc-tools.tcl (.../doc-tools.tcl) (revision 18ff1444fef5c209dfb40cf2ae694206c0d10309)
+++ library/lib/doc-tools.tcl (.../doc-tools.tcl) (revision 26ce746b45449fbff64f88c6d9e9050a63b89449)
@@ -36,7 +36,8 @@
#
# @param class Request an instance of a particular entity class (e.g., ...)
# @param name What is the entity name (e.g., nx::doc for a package)
- # @param args A vector of arbitrary arguments, provided to the entity when being constructed
+ # @param args A vector of arbitrary arguments, provided to the
+ # entity when being constructed
# @return The identifier of the newly created entity object
# @subcommand ::nx::doc::@#foo
@@ -94,6 +95,15 @@
return $result
}
+ proc sort_by_value {d} {
+ set haystack [list]
+ dict for {key value} $d {
+ lappend haystack [list $key $value]
+ }
+ return [dict create {*}[concat {*}[lsort -integer -index 1 -decreasing $haystack]]]
+ }
+
+
proc find_asset_path {{subdir library/lib/doc-assets}} {
# This helper tries to identify the file system path of the
# asset ressources.
@@ -113,23 +123,15 @@
:public method apply {} {
foreach mixin [:info children -type [current class]::Mixin] {
set base "${:prefix}::[namespace tail $mixin]"
- puts "TRYING mixin $mixin base $base"
if {[::nsf::isobject $base]} {
set scope [expr {[$mixin scope] eq "object" && [$base info is class]?"class-object":""}]
- puts stderr "APPLYING $base {*}$scope mixin add $mixin"
$base {*}$scope mixin add $mixin
}
}
}
Class create [current]::Mixin -superclass Class {
:attribute {scope class}
- :method init args {
- :public method foo {} {
- puts stderr "[current class]->[current method]";
- next
- }
- }
}
}
@@ -140,15 +142,18 @@
# basic name-generating mechanisms for documentation entities
# based on properties such as entity name, root namespace, etc.
#
- # @param tag Defaults to the tag label to be used in comment tags. It may vary from the auto-generated default!
- # @param root_namespace You may choose your own root-level namespace hosting the namespace hierarchy of entity objects
+ # @param tag Defaults to the tag label to be used in comment
+ # tags. It may vary from the auto-generated default!
+ # @param root_namespace You may choose your own root-level
+ # namespace hosting the namespace hierarchy of entity objects
:attribute {tag {[string trimleft [string tolower [namespace tail [current]]] @]}}
:attribute {root_namespace "::nx::doc::entities"}
namespace eval ::nx::doc::entities {}
:public class-object method normalise {tagpath names} {
+ # puts stderr "tagpath $tagpath names $names"
# 1) verify balancedness of
if {[llength $tagpath] != [llength $names]} {
return [list 1 "Imbalanced tag line spec: '$tagpath' vs. '$names'"]
@@ -188,7 +193,21 @@
set entity_path [list]
foreach axis $tagpath value $names {
if {$entity eq ""} {
- if {[QualifierTag info instances @$axis] eq "" && [Tag info instances @$axis] eq ""} {
+ set cmd [info command @$axis]
+ #
+ # TODO interp-aliasing objects under different command names
+ # is currently not transparent to some ::nsf::* helpers,
+ # such as ::nsf::isobject. Should this be changed?
+ #
+ if {$cmd ne ""} {
+ set cmd [namespace origin $cmd]
+ set target [interp alias {} $cmd]
+ if {$target ne ""} {
+ set cmd $target
+ }
+ }
+
+ if {$cmd eq "" || ![::nsf::isobject $cmd] || ![$cmd info has type Tag]} {
return [list 1 "The entity type '@$axis' is not available."]
}
set entity [@$axis id $value]
@@ -238,7 +257,8 @@
set partof_name [string trimleft $partof_name :]
return [join [list [:root_namespace] $subns $partof_name {*}$scope $name] ::]
} else {
- return "[:root_namespace]::${subns}$name"
+ set name [string trimleft $name :]
+ return "[:root_namespace]::${subns}::$name"
}
}
@@ -495,8 +515,14 @@
# @command nx
#
# @use ::nsf::command
- # @use {Object foo}
- # @use command {Object foo}
+
+ # or
+
+ # class.method {X foo}
+ #
+ # @use {Class foo}
+ # @use object.method {Object foo}
+
lassign $value pathspec pathnames
if {$pathnames eq ""} {
set pathnames $pathspec
@@ -602,12 +628,25 @@
Class create StructuredEntity -superclass Entity {
- :public method owned_parts {} {
+ :public method part_attributes {} {
set slots [:info lookup slots]
- set r [dict create]
-# puts stderr SLOTS=$slots
+ set attrs [list]
foreach s $slots {
if {![$s info has type ::nx::doc::PartAttribute] || ![$s eval {info exists :part_class}]} continue;
+ lappend attrs $s [$s part_class]
+ }
+ return $attrs
+ }
+ :public method owned_parts {} {
+ set r [dict create]
+ foreach {s cls} [:part_attributes] {
+ #
+ # TODO: there is no equivalent to mixinof/has mixin for the
+ # superclass-subclass axis: info superclassof | /cls/ has
+ # superclass | info subclassof | /cls/ has subclass; are info
+ # subclass and superclass sufficient?
+ #
+ # if {![$s info has type ::nx::doc::PartAttribute] || ![$s eval {info exists :part_class}] || [current class] ni [[$s eval {set :part_class}] info superclass -closure]} continue;
set accessor [$s name]
# puts stderr "PROCESSING ACCESSOR $accessor, [info exists :$accessor]"
if {[info exists :$accessor]} {
@@ -637,7 +676,7 @@
Class create [current]::Containable {
# TODO: check the interaction of required, per-object attribute and ::nsf::assertion
#:object attribute container:object,type=[:info parent],required
- :class-object attribute container:object,type=[:info parent]
+ :attribute container:object,type=[:info parent]
:method create args {
#
# Note: preserve the container currently set at this callstack
@@ -655,6 +694,24 @@
next
}
}
+ :method create args {
+ #
+ # Note: preserve the container currently set at this callstack
+ # level. [next] will cause the container to change if another
+ # container entity is initialised in the following!
+ #
+ if {[info exists :container]} {
+ set cont ${:container}
+ set obj [next]
+ if {![$obj eval {info exists :partof}]} {
+ $cont register $obj
+ }
+ return $obj
+ } else {
+ next
+ }
+ }
+
}
# Note: The default "" corresponds to the top-level namespace "::"!
:attribute {@namespace ""}
@@ -690,11 +747,14 @@
:method init {} {
next
+
QualifierTag mixin add [current class]::Resolvable
[current class]::Resolvable container [current]
- QualifierTag mixin add [current class]::Containable
- @package class-object mixin add [current class]::Containable
- [current class]::Containable container [current]
+
+ foreach {attr part_class} [:part_attributes] {
+ $part_class class-object mixin add [current class]::Containable
+ $part_class container [current]
+ }
}
:public method register {containable:object,type=::nx::doc::Entity} {
@@ -710,6 +770,10 @@
:attribute license
:attribute creationdate
:attribute {version ""}
+
+ :attribute @glossary -slotclass ::nx::doc::PartAttribute {
+ set :part_class ::nx::doc::@glossary
+ }
:attribute @package -slotclass ::nx::doc::PartAttribute {
set :part_class ::nx::doc::@package
@@ -747,12 +811,11 @@
:method require_part {domain prop value} {
set value [expr {![string match ":*" $value] ? "__out__: $value": "__out__$value"}]
next [list $domain $prop $value]
- #next $domain $prop "__out__ $value"
}
set :part_class ::nx::doc::@param
}
- :forward @sub-command %self @command
+ :public forward @sub-command %self @command
:attribute @command -slotclass ::nx::doc::PartAttribute {
:pretty_name "Subcommand"
:pretty_plural "Subcommands"
@@ -784,7 +847,7 @@
-mixin ContainerEntity::Containable {
:attribute @author -slotclass ::nx::doc::PartAttribute
- :forward @object %self @child-object
+ :public forward @object %self @child-object
:attribute @child-object -slotclass ::nx::doc::PartAttribute {
set :part_class ::nx::doc::@object
:public method id {domain prop value} {
@@ -798,7 +861,7 @@
}
- :forward @class %self @child-class
+ :public forward @class %self @child-class
:attribute @child-class -slotclass ::nx::doc::PartAttribute {
set :part_class ::nx::doc::@class
:public method id {domain prop value} {
@@ -811,12 +874,12 @@
}
}
- :forward @method %self @object-method
+ :public forward @method %self @object-method
:attribute @class-object-method -slotclass ::nx::doc::PartAttribute {
set :part_class ::nx::doc::@method
}
- :forward @attribute %self @class-object-attribute
+ :public forward @attribute %self @class-object-attribute
#:forward @param %self @object-param
:attribute @class-object-attribute -slotclass ::nx::doc::PartAttribute {
set :part_class ::nx::doc::@param
@@ -840,14 +903,14 @@
-superclass @object {
:attribute @superclass -slotclass ::nx::doc::PartAttribute
- :forward @attribute %self @class-attribute
+ :public forward @attribute %self @class-attribute
:attribute @class-attribute -slotclass ::nx::doc::PartAttribute {
:pretty_name "Per-class attribute"
:pretty_plural "Per-class attributes"
set :part_class ::nx::doc::@param
}
- :forward @method %self @class-method
+ :public forward @method %self @class-method
:attribute @class-method -slotclass ::nx::doc::PartAttribute {
:pretty_name "Per-class method"
:pretty_plural "Per-class methods"
@@ -933,9 +996,9 @@
- :forward @class-method %self @method
- :forward @class-object-method %self @method
- :forward @sub-method %self @method
+ :public forward @class-method %self @method
+ :public forward @class-object-method %self @method
+ :public forward @sub-method %self @method
:attribute @method -slotclass ::nx::doc::PartAttribute {
set :part_class ::nx::doc::@method
:public method id {domain prop name} {
@@ -1123,6 +1186,19 @@
interp alias {} ::nx::doc::@attribute {} ::nx::doc::@param
interp alias {} ::nx::doc::@parameter {} ::nx::doc::@param
+ #
+ # Providing interp-wide aliases for @glossary. For most processing
+ # steps, this is syntactic sugar, however, the aliases cause
+ # different rendering behaviour for glossary references and entries.
+ #
+
+ interp alias {} ::nx::doc::@gls {} ::nx::doc::@glossary
+ interp alias {} ::nx::doc::@Gls {} ::nx::doc::@glossary
+ interp alias {} ::nx::doc::@glspl {} ::nx::doc::@glossary
+ interp alias {} ::nx::doc::@Glspl {} ::nx::doc::@glossary
+ interp alias {} ::nx::doc::@acr {} ::nx::doc::@glossary
+ interp alias {} ::nx::doc::@acrfirst {} ::nx::doc::@glossary
+
namespace export CommentBlockParser @command @object @class @package \
@project @method @attribute @parameter @
}
@@ -1176,11 +1252,16 @@
} {
# Here, we assume the -nonleaf mode being active for {{{[eval]}}}.
set tmplscript [list subst [:read_tmpl $template]]
+ #
+ # TODO: This looks awkward, however, till all requirements are
+ # figured out (as for the origin mechanism) we so keep track
+ # of the actual rendered entity ... review later ...
+ #
+ $entity rendered_entity $entity
$entity eval [subst -nocommands {
$initscript
$tmplscript
}]
- # $entity eval [list subst $template]
}
@@ -1263,28 +1344,38 @@
}
set :markup_map(sub) {
- "{{{" "\[:code \{"
- "}}}" "\}\]"
- "{{" "\[:link "
- "}}" "\]"
+ "'''" "\[:listing \{"
+ "'''" "\}\]"
+ "<<" "\[:link "
+ ">>" "\]"
}
set :markup_map(unescape) {
"\\{" "{"
"\\}" "}"
"\\#" "#"
+ "\\<" "<"
+ "\\>" ">"
+ "\\'" "'"
}
- :method map {line set} {
- set line [string map [[::nsf::current class] eval [list set :markup_map($set)]] $line]
+ :method unescape {line} {
+ set line [string map [[::nsf::current class] eval [list set :markup_map(unescape)]] $line]
}
+ :method map {line} {
+ regsub -all -- {('''([^']+?)''')} $line {[:listing {\2}]} line
+ regsub -all -- {(<<([^<]+?)>>)} $line {[:link \2]} line
+ return $line
+ }
+
+
:method as_list {} {
set preprocessed [list]
set is_code_block 0
foreach line [next] {
- if {[regsub -- {^\s*(\{\{\{)\s*$} $line "\[:code -inline false \{" line] || \
- (${is_code_block} && [regsub -- {^\s*(\}\}\})\s*$} $line "\}\]" line])} {
+ if {(!${is_code_block} && [regsub -- {^\s*(''')\s*$} $line "\[:listing -inline false \{" line]) || \
+ (${is_code_block} && [regsub -- {^\s*(''')\s*$} $line "\}\]" line])} {
set is_code_block [expr {!$is_code_block}]
append line \n
} elseif {${is_code_block}} {
@@ -1305,8 +1396,8 @@
:public method as_text {} {
set preprocessed [join [:as_list] " "]
- set preprocessed [:map $preprocessed sub]
- set preprocessed [:map $preprocessed unescape]
+ set preprocessed [:map $preprocessed]
+ set preprocessed [:unescape $preprocessed]
return [subst $preprocessed]
}
@@ -1334,38 +1425,42 @@
set top_level_entities [:owned_parts]
dict for {feature instances} $top_level_entities {
if {[$feature name] eq "@package"} {
- foreach {entity_type pkg_entities} [$feature owned_parts] {
- dict lappend top_level_entities $entity_type {*}$pkg_entities
+ foreach pkg $instances {
+ dict for {pkg_feature pkg_feature_instances} [$pkg owned_parts] {
+ dict lappend top_level_entities $pkg_feature {*}$pkg_feature_instances
+ }
}
}
}
set init [subst {
- set project [current object]
+ set project \[:current_project\]
set project_entities \[list $top_level_entities\]
}]
set project_path [file join $outdir [string trimleft ${:name} :]]
if {![catch {file mkdir $project_path} msg]} {
- # puts stderr [list file copy -force -- [$renderer find_asset_path] $project_path/assets]
set assets [lsearch -all -inline -glob -not [glob -directory [find_asset_path] *] *.tmpl]
set target $project_path/assets
file mkdir $target
file copy -force -- {*}$assets $target
set values [join [dict values $top_level_entities]]
- # puts stderr "VALUES=$values"
+
+ #
+ # Make sure that the @project entity is processed last.
+ #
+ lappend values [current object]
foreach e $values {
- #puts stderr "PROCESSING=$e render -initscript $init $tmpl"
+ #
+ # TODO: For now, in templates we (silently) assume that we act
+ # upon structured entities only ...
+ #
+ if {![$e info has type ::nx::doc::StructuredEntity]} continue;
+ $e current_project [current object]
set content [$e render -initscript $init $tmpl]
:write_data $content [file join $project_path "[$e filename].$ext"]
puts stderr "$e written to [file join $project_path [$e filename].$ext]"
}
-
- set index [:render -initscript $init $tmpl]
- # puts stderr "we have [llength $entities] documentation entities ($entities)"
- :write_data $index [file join $project_path "index.$ext"]
-
-
}
# 3) TODO: revoke the application of the mixin layer (for the sake of
@@ -1377,6 +1472,30 @@
#
MixinLayer::Mixin create [current]::Entity -superclass TemplateData {
+ #
+ # TODO: Would it be useful to allow attribute slots to describe
+ # a per-class-object state, while the accessor/mutator methods
+ # are defined on the per-class level. It feels like the class
+ # instance variables in Smalltalk ...
+ #
+ # TODO: Why is call protection barfing when the protected target
+ # is called from within a public forward. This should qualify as
+ # a valid call site (from "within" the same object!), shouldn't it?
+ # :protected class-object attribute current_project:object,type=::nx::doc::@project
+ :class-object attribute current_project:object,type=::nx::doc::@project
+ :public forward current_project [current] %method
+
+ #
+ # TODO: For now, this acts as the counterweight to "origin",
+ # when @use aliasing is used, processed_entity can be used to
+ # refer to the actual entity at the upper end of the aliasing
+ # chain. Verify, whether this is an acceptable approach ...
+ #
+ :class-object attribute rendered_entity:object,type=::nx::doc::Entity
+ :public forward rendered_entity [current] %method
+
+ :public forward print_name %current name
+
:method fit {str max {placeholder "..."}} {
if {[llength [split $str ""]] < $max} {
return $str;
@@ -1400,7 +1519,7 @@
# @object instances. Untangle!
set access [expr {[$inst eval {info exists :@modifier}]?[$inst @modifier]:""}]
set host ${:name}
- set name [$inst name]
+ set name [$inst print_name]
set url "[:filename].html#[string trimleft [$feature name] @]_[$inst name]"
set type [$feature name]
lappend entries [subst $entry]
@@ -1409,30 +1528,35 @@
return "\[[join $entries ,\n]\]"
}
- :method code {{-inline true} script} {
+ :method listing {{-inline true} script} {
return [expr {$inline?"$script
":"
$script"}] } :method link {tag names} { - #puts stderr "RESOLVING tag $tag names $names" set tagpath [split [string trimleft $tag @] .] lassign [::nx::doc::Tag normalise $tagpath $names] err res if {$err} { - #puts stderr RES=$res + puts stderr RES=$res return "?"; } lassign [::nx::doc::Tag find -all -strict {*}$res] err path if {$err || $path eq ""} { - #puts stderr "FAILED res $path (err-$err-id-[expr {$path eq ""}])" + # puts stderr "FAILED res $path (err-$err-id-[expr {$path eq ""}])" return "?"; } set path [dict create {*}$path] set entities [dict keys $path] set id [lindex $entities end] - return [$id render_link $tag [current] $path] + return [$id render_link $tag [:rendered_entity] $path] } + :public method make_link {source} { + set path [dict create {*}[:get_upward_path -attribute {set :name}]] + set tag [[:info class] tag] + return [:render_link $tag $source $path] + } + :public method render_link {tag source path} { #puts stderr PATH=$path set id [current] @@ -1485,31 +1609,90 @@ } }; # NxDocTemplating::Entity + MixinLayer::Mixin create [current]::@project -superclass [current]::Entity { + :public method filename {} { + return "index" + } + } + MixinLayer::Mixin create [current]::@glossary -superclass [current]::Entity { - + :public method print_name {} { + return [expr {[info exists :@acronym]?${:@acronym}:${:@pretty_name}}] + } + + array set :tags { + @gls { + set print_name [string tolower ${:@pretty_name} 0 0] + set title ${:@pretty_name} + } + @Gls { + set print_name [string toupper ${:@pretty_name} 0 0] + set title ${:@pretty_name} + } + @glspl { + set print_name [string tolower ${:@pretty_plural} 0 0] + set title ${:@pretty_plural} + } + @Glspl { + set print_name [string toupper ${:@pretty_plural} 0 0] + set title ${:@pretty_plural} + } + @acr { + set acronym(short) 1 + } + @acrfirst { + set acronym(long) 1 + } + + } + + :public method href {-local:switch top_entity:optional} { + set fragments "#${:name}" + if {$local} { + return $fragments + } else { + return "[[:current_project] filename].html$fragments" + } + + } + :public method render_link {tag source path} { + # tag-specific rendering + set acronym(long) 0 + set acronym(short) 0 + set print_name ${:@pretty_name} + set title ${:@pretty_name} + if {[[current class] eval [list info exists :tags($tag)]]} { + eval [[current class] eval [list set :tags($tag)]] + } + if {[info exists :@acronym]} { + # + # First occurrance of an acronym entry! + # + if {!$acronym(short) && ($acronym(long) || ![info exists :refs] || \ + ![dict exists ${:refs} $source])} { + set print_name "$print_name (${:@acronym})" + set res "$print_name" + } else { + set title $print_name + set print_name ${:@acronym} + set anchor "$print_name" + set res "$anchor" + } + } else { + set res "$print_name" + } + + # record for reverse references if {![info exists :refs]} { set :refs [dict create] } dict incr :refs $source - # TODO: provide the project context here and render the - # glossary location accordingly, rather than hard-code "index.html". - return "[string tolower ${:@pretty_name}]" - } - # - # TODO: this should go into the appropriate template - # - :public method render_refs {} { - if {[info exists :refs]} { - dict for {entity count} ${:refs} { - } - } - } - + return $res + } } - }; # NxDocTemplating # @@ -2047,14 +2230,14 @@ return $parser_obj } - :forward has_next expr {${:idx} < [llength ${:comment_block}]} - :method dequeue {} { + :public forward has_next expr {${:idx} < [llength ${:comment_block}]} + :public method dequeue {} { set r [lindex ${:comment_block} ${:idx}] incr :idx return $r } - :forward rewind incr :idx -1 - :forward fastforward set :idx {% llength ${:comment_block}} + :public forward rewind incr :idx -1 + :public forward fastforward set :idx {% llength ${:comment_block}} :public method cancel {statuscode {msg ""}} { :fastforward @@ -2201,7 +2384,7 @@ } } - :forward event=parse %self {% subst {parse@${:current_comment_line_type}}} + :public forward event=parse %self {% subst {parse@${:current_comment_line_type}}} :method event=next {line} { set next_section [[${:block_parser} processed_section] next_comment_section] :on_exit $line @@ -2216,15 +2399,16 @@ # realise the sub-state (a variant of METHOD-FOR-STATES) and their # specific event handling + # set :lineproc {{tag args} {return [concat {*}$args]}} + set :lineproc {{tag args} {return [list $tag $args]}} :method parse@tag {line} { - set line [split [string trimleft $line]] - set tag [lindex $line 0] + lassign [apply [[current class] eval {set :lineproc}] {*}$line] tag line if {[:info lookup methods -source application $tag] eq ""} { set msg "The tag '$tag' is not supported for the entity type '[namespace tail [:info class]]" ${:block_parser} cancel INVALIDTAG $msg } -# puts stderr ":$tag [lrange $line 1 end]" - :$tag [lrange $line 1 end] + #:$tag [lrange $line 1 end] + :$tag $line } :method parse@text {line} { @@ -2279,61 +2463,9 @@ } } - # realise the parse events specific to the substates of description + set :lineproc {{tag name args} {return [list $tag $name $args]}} :method parse@tag {line} { - # - # When hitting this parsing step, we have an unresolved - # entity. The context section specifies the entity to create - # or to resolve for further processing. - # - set line [split [string trimleft $line]] - set args [lassign $line tag name] - lassign [:resolve_partof_entity $tag $name] nq_name partof_entity - if {$partof_entity ne ""} { - if {[$partof_entity info lookup methods -source application $tag] eq ""} { - ${:block_parser} cancel INVALIDTAG "The tag '$tag' is not supported for the entity type - '[namespace tail [$partof_entity info class]]'" - # [InvalidTag new -message [subst { - # The tag '$tag' is not supported for the entity type - # '[namespace tail [$partof_entity info class]]' - # }]] throw - } - # puts stderr "$partof_entity $tag $nq_name {*}$args" - set current_entity [$partof_entity $tag $nq_name {*}$args] - - } else { - # - # TODO: @object-method raises some issues (at least when - # processed without a resolved context = its partof entity). - # It is not an entity type, because it merely is a "scoped" - # @method. It won't resolve then as a proper instance of - # Tag, hence we observe an InvalidTag exception. For - # now, we just ignore and bypass this issue by allowing - # InvalidTag exceptions in analyze() - # - set qualified_tag [namespace qualifiers [current]]::$tag - ${:block_parser} cancel INVALIDTAG "The entity type '$tag' is not available" - # if {[Tag info instances -closure $qualified_tag] eq ""} { - # [InvalidTag new -message [subst { - # The entity type '$tag' is not available - # }]] throw - # } - # puts stderr "$tag new -name $nq_name {*}$args" - set current_entity [$tag new -name $nq_name {*}$args] - } - # - # make sure that the current_entity has parser capabilities - # and the relevant state of the previous entity before the - # context switch - # TODO: refactor later - ${:block_parser} current_entity $current_entity - ${:block_parser} processed_section [current class] - $current_entity current_comment_line_type ${:current_comment_line_type} - $current_entity block_parser ${:block_parser} - } - - :method parse@tag {line} { - set args [lassign $line axes names] + lassign [apply [[current class] eval {set :lineproc}] {*}$line] axes names args set entity ${:partof_entity} set axes [split [string trimleft $axes @] .] @@ -2368,13 +2500,38 @@ set entity $res if {$entity eq ""} { - if {[QualifierTag info instances @$leaf(axis)] eq "" && [Tag info instances @$leaf(axis)] eq ""} { + set cmd [info commands @$leaf(axis)] + + # TODO interp-aliasing objects under different command names + # is currently not transparent to some ::nsf::* helpers, + # such as ::nsf::isobject. Should this be changed? + # + if {$cmd ne ""} { + set cmd [namespace origin $cmd] + set target [interp alias {} $cmd] + if {$target ne ""} { + set cmd $target + } + } + + if {$cmd eq "" || ![::nsf::isobject $cmd] || \ + ![$cmd info has type Tag]} { + ${:block_parser} cancel INVALIDTAG "The entity type '@$leaf(axis)' is not available." } + + # VERIFY! Still an issue? TODO: @object-method raises some + # issues (at least when processed without a resolved + # context = its partof entity). It is not an entity type, + # because it merely is a "scoped" @method. It won't + # resolve then as a proper instance of Tag, hence we + # observe an InvalidTag exception. For now, we just ignore + # and bypass this issue by allowing InvalidTag exceptions + # in analyze() + set entity [@$leaf(axis) new -name $leaf(name) {*}$args] } else { if {[$entity info lookup methods -source application @$leaf(axis)] eq ""} { -okup()) ${:block_parser} cancel INVALIDTAG "The tag '$leaf(axis)' is not supported for the entity type '[namespace tail [$entity info class]]'" } set entity [$entity @$leaf(axis) [list $leaf(name) {*}$args]]