Index: library/lib/doc-tools.tcl
===================================================================
diff -u -r8ee718fe7e27c3df71bc659f3261710a4aaf5805 -r459ae500daf2a8e5012c8f59519d3adfd7e3c2e7
--- library/lib/doc-tools.tcl (.../doc-tools.tcl) (revision 8ee718fe7e27c3df71bc659f3261710a4aaf5805)
+++ library/lib/doc-tools.tcl (.../doc-tools.tcl) (revision 459ae500daf2a8e5012c8f59519d3adfd7e3c2e7)
@@ -108,7 +108,76 @@
:attribute {root_namespace "::nx::doc::entities"}
namespace eval ::nx::doc::entities {}
+
+ :public class-object method normalise {tagpath names} {
+ # 1) verify balancedness of
+ if {[llength $tagpath] != [llength $names]} {
+ return [list 1 "Imbalanced tag line spec: '$tagpath' vs. '$names'"]
+ }
+
+ # 2) expand shortcuts (i.e., nested lists into additional tag
+ # path elements) and flatten the tagpath list.
+ set expanded [list]
+
+ foreach n $names {
+ lappend expanded {*}[lrepeat [llength $n] [lindex $tagpath [lsearch -exact $names $n]]]
+ }
+
+ return [list 0 [list $expanded [concat {*}$names]]]
+
+ }
+ :public class-object method find {
+ -strict:switch
+ -all:switch
+ tagpath
+ names
+ {entity ""}} {
+
+ if {[llength $tagpath] != [llength $names]} {
+ return [list 1 "Imbalanced tag line spec: '$tagpath' vs. '$names'"]
+ }
+
+ # make sure that expansion has been applied (not allowing sub-lists in names!)
+
+ if {[concat {*}$names] ne $names} {
+ return [list 1 "Names list contains sub-lists. Not expanded?"]
+ }
+
+ set last_axis [expr {$entity ne ""?[$entity info class]:""}]
+ set last_name [expr {$entity ne ""?[$entity name]:""}]
+ set entity_path [list]
+ foreach axis $tagpath value $names {
+ if {$entity eq ""} {
+ if {[QualifierTag info instances @$axis] eq "" && [Tag info instances @$axis] eq ""} {
+ return [list 1 "The entity type '@$axis' is not available."]
+ }
+ set entity [@$axis id $value]
+ } else {
+ if {$strict && ![::nsf::isobject $entity]} {
+ return [list 1 "The tag path '$tagpath' -> '$names' points to a non-existing documentation entity: '@$last_axis' -> '$last_name'"]
+ }
+ if {$all} {lappend entity_path $entity [$entity name]}
+ set entity [$entity origin]
+ if {[$entity info lookup methods -source application @$axis] eq ""} {
+ return [list 1 "The tag '$axis' is not supported for the entity type '[namespace tail [$entity info class]]'"]
+ }
+ #puts stderr "$entity @$axis id $value"
+ set entity [$entity @$axis id $value]
+ set last_axis $axis
+ set last_name $value
+ }
+ }
+
+ if {$strict && $entity ne "" && ![::nsf::isobject $entity]} {
+ return [list 1 "The tag path '$tagpath' -> '$names' points to a non-existing documentation entity: '@$last_axis' -> '$last_name'"]
+ }
+ if {$all} {lappend entity_path $entity [$entity name]}
+
+
+ return [list 0 [expr {$all?$entity_path:$entity}]]
+ }
+
# @method id
#
# A basic generator for the characteristic ideas, based on the
@@ -120,7 +189,7 @@
# @see tag
# @see root_namespace
- :method id {
+ :public method id {
-partof_name
{-scope ""}
name
@@ -134,7 +203,7 @@
}
}
- :method new {
+ :public method new {
-part_attribute
-partof:object,type=::nx::doc::Entity
-name:required
@@ -179,12 +248,12 @@
# @method get_unqualified_name
#
# @param qualified_name The fully qualified name (i.e., including the root namespace)
- :method get_unqualified_name {qualified_name} {
+ :public method get_unqualified_name {qualified_name} {
# TODO: danger, tcl-commands in comments
# similar to \[namespace tail], but the "tail" might be an object with a namespace
return [string trimleft [string map [list [:root_namespace] ""] $qualified_name] ":"]
}
- :method get_tail_name {qualified_name} {
+ :public method get_tail_name {qualified_name} {
return [string trimleft [string map [list ${:tag} ""] [:get_unqualified_name $qualified_name]] ":"]
}
}
@@ -197,7 +266,7 @@
return $name
}
- :method id {
+ :public method id {
-partof_name
{-scope ""}
name
@@ -213,7 +282,7 @@
}
}
- :method new {
+ :public method new {
-part_attribute
-partof:object,type=::nx::doc::Entity
-name:required
@@ -234,11 +303,11 @@
}
Class create PartTag -superclass Tag {
- :method id {partof_name scope name} {
- next -partof_name $partof_name -scope $scope $name
+ :public method id {partof_name scope name} {
+ next [list -partof_name $partof_name -scope $scope $name]
}
- :method new {
+ :public method new {
-part_attribute:required
-partof:object,type=::nx::doc::Entity
-name
@@ -272,6 +341,9 @@
:attribute part_class:optional,class
:attribute scope
+ :attribute {pretty_name {[string totitle [string trimleft [namespace tail [current]] @]]}}
+ :attribute {pretty_plural {[string totitle [string trimleft [namespace tail [current]] @]]}}
+
# :forward owning_entity_class {% [[:info parent] info parent] }
:method init args {
:defaultmethods [list get append]
@@ -287,7 +359,7 @@
next
}
- :method id {domain prop value} {
+ :public method id {domain prop value} {
#puts stderr "PARTATTRIBUTE-ID: [current args]"
if {![info exists :part_class]} {
error "Requested id generation from a simple part attribute!"
@@ -314,25 +386,25 @@
}
return $value
}
- :method append {domain prop value} {
+ :public method append {domain prop value} {
:add $domain $prop $value end
}
- :method assign {domain prop value} {
+ :public method assign {domain prop value} {
set parts [list]
foreach v $value {
lappend parts [:require_part $domain $prop $v]
}
- next $domain $prop $parts
+ next [list $domain $prop $parts]
}
- :method add {domain prop value {pos 0}} {
+ :public method add {domain prop value {pos 0}} {
set p [:require_part $domain $prop $value]
if {![$domain eval [list info exists :$prop]] || $p ni [$domain $prop]} {
- next $domain $prop $p $pos
+ next [list $domain $prop $p $pos]
}
return $p
}
- :method delete {domain prop value} {
- next $domain $prop [:require_part $prop $value]
+ :public method delete {domain prop value} {
+ next [list $domain $prop [:require_part $prop $value]]
}
}
@@ -347,15 +419,87 @@
:attribute name:required
# every Entity must be created with a "@doc" value and can have
# an optional initcmd
- :method objectparameter args {next {@doc:optional __initcmd:initcmd,optional}}
+ :method objectparameter args {
+ next [list [list @doc:optional __initcmd:initcmd,optional]]
+ }
:attribute partof:object,type=::nx::doc::StructuredEntity
:attribute part_attribute:object,type=::nx::doc::PartAttribute
+
+ :public method get_upward_path {
+ -relative:switch
+ {-attribute {set :name}}
+ {-type ::nx::doc::Entity}
+ } {
+ set path [list]
+ if {!$relative} {
+ lappend path [list [current] [:eval $attribute]]
+ }
+ #puts stderr ARGS=[current args]-[info exists :partof]
+ #puts stderr HELP=$path
+
+ if {[info exists :partof] && [${:partof} info has type $type]} {
+ #puts stderr "CHECK ${:partof} info has type $type -> [${:partof} info has type $type]"
+
+ set path [concat [${:partof} [current method] -attribute $attribute -type $type] $path]
+ }
+ #puts stderr PATHRETURN=$path
+ return [concat {*}$path]
+ }
:attribute @doc:multivalued {set :incremental 1}
:attribute @see -slotclass ::nx::doc::PartAttribute
:attribute @properties -slotclass ::nx::doc::PartAttribute
+ :attribute @use {
+ :public method assign {domain prop value} {
+ # @command nx
+ #
+ # @use ::nsf::command
+ # @use {Object foo}
+ # @use command {Object foo}
+ lassign $value pathspec pathnames
+ if {$pathnames eq ""} {
+ set pathnames $pathspec
+ # puts stderr PATH=[$domain get_upward_path \
+ # -attribute {[:info class] tag}]
+ # puts stderr "dict create {*}[$domain get_upward_path \
+ # -attribute {[:info class] tag}]"
+ set pathspec [dict create {*}[$domain get_upward_path \
+ -attribute {[:info class] tag}]]
+ set pathspec [dict values $pathspec]
+ } else {
+ set pathspec [split $pathspec .]
+ }
+ #puts stderr "PATHSPEC $pathspec PATHNAMES $pathnames"
+ lassign [::nx::doc::Tag normalise $pathspec $pathnames] err res
+ if {$err} {
+ error "Invalid @use values provided: $res"
+ }
+
+ lassign $res pathspec pathnames
+
+ lassign [::nx::doc::Tag find $pathspec $pathnames] err res
+ if {$err} {
+ error "Generating an entity handle failed: $res"
+ }
+ #puts stderr "next $domain $prop $res"
+ next [list $domain $prop $res]
+ }
+
+ }
+
+ :public method origin {} {
+ if {[info exists :@use]} {
+ #puts stderr ORIGIN(${:@use})=isobj-[::nsf::isobject ${:@use}]
+ if {![::nsf::isobject ${:@use}] || ![${:@use} info has type [:info class]]} {
+ error "Referring to a non-existing doc entity or a doc entity of a different type."
+ }
+ return [${:@use} origin]
+ }
+ return [current]
+ }
+
:method has_property {prop} {
if {![info exists :@properties]} {return 0}
expr {$prop in ${:@properties}}
@@ -393,40 +537,36 @@
# but looks for now convenient.
#
- :method as_list {} {
+ :public method as_list {} {
if {[info exists :@doc] && ${:@doc} ne ""} {
#puts stderr DOC=${:@doc}
set non_empty_elements [lsearch -all -not -exact ${:@doc} ""]
return [lrange ${:@doc} [lindex $non_empty_elements 0] [lindex $non_empty_elements end]]
}
}
- :method as_text {} {
+ :public method as_text {} {
set doc [list]
set lines [:as_list]
- foreach l [:as_list] {
+ foreach l $lines {
lappend doc [string trimleft $l]
}
return [subst [join $doc " "]]
}
-
- :method filename {} {
- return [[:info class] tag]_[string trimleft [string map {:: __} ${:name}] "_"]
- }
}
Class create StructuredEntity -superclass Entity {
- :method owned_parts {} {
- set slots [:info slotobjects]
+ :public method owned_parts {} {
+ set slots [:info lookup slots]
set r [dict create]
# puts stderr SLOTS=$slots
foreach s $slots {
if {![$s info has type ::nx::doc::PartAttribute] || ![$s eval {info exists :part_class}]} continue;
set accessor [$s name]
# puts stderr "PROCESSING ACCESSOR $accessor, [info exists :$accessor]"
if {[info exists :$accessor]} {
- dict set r $accessor [sorted [:$accessor] name]
+ dict set r $s [sorted [:$accessor] name]
}
}
return $r
@@ -475,14 +615,20 @@
:attribute {@namespace ""}
:attribute @class -slotclass ::nx::doc::PartAttribute {
- set :part_class @class
+ :pretty_name "Class"
+ :pretty_plural "Classes"
+ set :part_class ::nx::doc::@class
}
:attribute @object -slotclass ::nx::doc::PartAttribute {
- set :part_class @object
+ :pretty_name "Object"
+ :pretty_plural "Objects"
+ set :part_class ::nx::doc::@object
}
:attribute @command -slotclass ::nx::doc::PartAttribute {
- set :part_class @command
+ :pretty_name "Command"
+ :pretty_plural "Commands"
+ set :part_class ::nx::doc::@command
}
# :attribute @class:object,type=::nx::doc::@class,multivalued {
@@ -506,7 +652,7 @@
[current class]::Containable container [current]
}
- :method register {containable:object,type=::nx::doc::Entity} {
+ :public method register {containable:object,type=::nx::doc::Entity} {
set tag [[$containable info class] tag]
if {[:info lookup methods -source application "@$tag"] ne ""} {
:@$tag $containable
@@ -521,7 +667,7 @@
:attribute {version ""}
:attribute @package -slotclass ::nx::doc::PartAttribute {
- set :part_class @package
+ set :part_class ::nx::doc::@package
}
}
@@ -550,22 +696,30 @@
QualifierTag create @command -superclass StructuredEntity {
:attribute @parameter -slotclass ::nx::doc::PartAttribute {
- set :part_class @param
+ set :part_class ::nx::doc::@param
}
:attribute @return -slotclass ::nx::doc::PartAttribute {
:method require_part {domain prop value} {
set value [expr {![string match ":*" $value] ? "__out__: $value": "__out__$value"}]
- next $domain $prop $value
+ next [list $domain $prop $value]
#next $domain $prop "__out__ $value"
}
- set :part_class @param
+ set :part_class ::nx::doc::@param
}
:forward @sub-command %self @command
:attribute @command -slotclass ::nx::doc::PartAttribute {
- set :part_class @command
+ :pretty_name "Subcommand"
+ :pretty_plural "Subcommands"
+ :public method id {domain prop value} {
+ # TODO: [${:part_class}] resolves to the attribute slot
+ # object, not the global @command object. is this intended, in
+ # line with the intended semantics?
+ return [${:part_class} [current method] -partof_name [$domain name] -scope ${:scope} $value]
+ }
+ set :part_class ::nx::doc::@command
}
- :method parameters {} {
+ :public method parameters {} {
set params [list]
if {[info exists :@parameter]} {
foreach p [:@parameter] {
@@ -587,8 +741,8 @@
:forward @object %self @child-object
:attribute @child-object -slotclass ::nx::doc::PartAttribute {
- set :part_class @object
- :method id {domain prop value} {
+ set :part_class ::nx::doc::@object
+ :public method id {domain prop value} {
# puts stderr "CHILD-OBJECT: [current args]"
# if {![info exists :part_class]} {
# error "Requested id generation from a simple part attribute!"
@@ -601,8 +755,8 @@
:forward @class %self @child-class
:attribute @child-class -slotclass ::nx::doc::PartAttribute {
- set :part_class @class
- :method id {domain prop value} {
+ set :part_class ::nx::doc::@class
+ :public method id {domain prop value} {
#puts stderr "CHILD-CLASS: [current args]"
# if {![info exists :part_class]} {
# error "Requested id generation from a simple part attribute!"
@@ -613,20 +767,20 @@
}
:forward @method %self @object-method
- :attribute @object-method -slotclass ::nx::doc::PartAttribute {
- set :part_class @method
+ :attribute @class-object-method -slotclass ::nx::doc::PartAttribute {
+ set :part_class ::nx::doc::@method
}
- :forward @attribute %self @object-attribute
+ :forward @attribute %self @class-object-attribute
#:forward @param %self @object-param
- :attribute @object-attribute -slotclass ::nx::doc::PartAttribute {
- set :part_class @param
+ :attribute @class-object-attribute -slotclass ::nx::doc::PartAttribute {
+ set :part_class ::nx::doc::@param
}
:method undocumented {} {
# TODO: for object methods and class methods
if {![::nsf::isobject ${:name}]} {return ""}
- foreach m [${:name} info methods] {set available_method($m) 1}
+ foreach m [${:name} info methods -callprotection all] {set available_method($m) 1}
set methods ${:@method}
if {[info exists :@param]} {set methods [concat ${:@method} ${:@param}]}
foreach m $methods {
@@ -643,12 +797,16 @@
:forward @attribute %self @class-attribute
:attribute @class-attribute -slotclass ::nx::doc::PartAttribute {
- set :part_class @param
+ :pretty_name "Per-class attribute"
+ :pretty_plural "Per-class attributes"
+ set :part_class ::nx::doc::@param
}
:forward @method %self @class-method
:attribute @class-method -slotclass ::nx::doc::PartAttribute {
- set :part_class @method
+ :pretty_name "Per-class method"
+ :pretty_plural "Per-class methods"
+ set :part_class ::nx::doc::@method
:method require_part {domain prop value} {
# TODO: verify whether these scoping checks are sufficient
# and/or generalisable: For instance, is the scope
@@ -695,7 +853,7 @@
-superclass StructuredEntity {
:attribute {@modifier public} -slotclass ::nx::doc::PartAttribute
:attribute @parameter -slotclass ::nx::doc::PartAttribute {
- set :part_class @param
+ set :part_class ::nx::doc::@param
}
:attribute @return -slotclass ::nx::doc::PartAttribute {
@@ -709,12 +867,12 @@
#
:method require_part {domain prop value} {
set value [expr {![string match ":*" $value] ? "__out__: $value": "__out__$value"}]
- next $domain $prop $value
+ next [list $domain $prop $value]
}
- set :part_class @param
+ set :part_class ::nx::doc::@param
}
- :class-object method new {
+ :public class-object method new {
-part_attribute:required
-partof:object,type=::nx::doc::Entity
-name
@@ -731,11 +889,11 @@
:forward @class-method %self @method
- :forward @object-method %self @method
+ :forward @class-object-method %self @method
:forward @sub-method %self @method
:attribute @method -slotclass ::nx::doc::PartAttribute {
- set :part_class @method
- :method id {domain prop name} {
+ set :part_class ::nx::doc::@method
+ :public method id {domain prop name} {
# TODO: ${:part_class} resolves to the local slot
# [current], rather than ::nx::doc::@method. Why?
if {[$domain info has type ::nx::doc::@method]} {
@@ -752,7 +910,7 @@
# }
}
- :method parameters {} {
+ :public method parameters {} {
set params [list]
if {[info exists :@parameter]} {
foreach p [:@parameter] {
@@ -768,7 +926,7 @@
# TODO: make me conditional, MARKUP should be in templates
set object [${:partof} name]
if {[::nsf::isobject $object]} {
- if {[$object info methods ${:name}] ne ""} {
+ if {[$object info methods -callprotection all ${:name}] ne ""} {
set actualParams ""
if {[$object info method type ${:name}] eq "forward"} {
set cmd ""
@@ -828,7 +986,7 @@
return $params
}
- :method get_sub_methods {} {
+ :public method get_sub_methods {} {
if {[info exists :@method]} {
set leaves [list]
foreach m ${:@method} {
@@ -844,7 +1002,7 @@
}
}
- :method get_combined {what} {
+ :public method get_combined {what} {
set result [list]
if {[info exists :partof] && [${:partof} info has type [current class]]} {
lappend result {*}[${:partof} get_combined $what] [:$what]
@@ -869,8 +1027,8 @@
:attribute default
- :class-object method id {partof_name scope name} {
- next [:get_unqualified_name ${partof_name}] $scope $name
+ :public class-object method id {partof_name scope name} {
+ next [list [:get_unqualified_name ${partof_name}] $scope $name]
}
# :class-object method id {partof_name name} {
@@ -884,7 +1042,7 @@
# return [:root_namespace]::${:tag}::${partof_fragment}::${name}
# }
- # @object-method new
+ # @class-object-method new
#
# The per-object method refinement indirects entity creation
# to feed the necessary ingredients to the name generator
@@ -893,7 +1051,7 @@
# @param -partof
# @param -name
# @param args
- :class-object method new {
+ :public class-object method new {
-part_attribute
-partof:required
-name
@@ -920,16 +1078,16 @@
interp alias {} ::nx::doc::@attribute {} ::nx::doc::@param
interp alias {} ::nx::doc::@parameter {} ::nx::doc::@param
- namespace export CommentBlockParser @command @object @class @package @project @method \
- @attribute @parameter @
+ namespace export CommentBlockParser @command @object @class @package \
+ @project @method @attribute @parameter @
}
namespace eval ::nx::doc {
Class create TemplateDataClass -superclass Class {
- :method find_asset_path {{-subdir library/lib/doc-assets}} {
+ :public method find_asset_path {{-subdir library/lib/doc-assets}} {
# This helper tries to identify the file system path of the
# asset ressources.
#
@@ -942,7 +1100,7 @@
}
}
- :method read_tmpl {path} {
+ :public method read_tmpl {path} {
if {[file pathtype $path] ne "absolute"} {
set assetdir [:find_asset_path]
set tmpl [file join $assetdir $path]
@@ -969,7 +1127,7 @@
# This mixin class realises a rudimentary templating language to
# be used in nx::doc templates. It realises language expressions
# to verify the existence of variables and simple loop constructs
- :method render {
+ :public method render {
{-initscript ""}
template
{entity:substdefault "[current]"}
@@ -987,21 +1145,41 @@
#
# some instructions for a dwarfish, embedded templating language
#
- :method let {var value} {
- uplevel 1 [list ::set $var [expr {[info exists value]?$value:""}]]
+ :method !let {var value} {
+ # uplevel 1 [list ::set $var [expr {[info exists value]?$value:""}]]
+ uplevel 1 [list ::set $var $value]
return
}
+
+ :method !get {-sortedby varname} {
+ if {[info exists sortedby]} {
+ uplevel 1 [list sorted [[:origin] eval [list ::set :$varname]] $sortedby]
+ } else {
+ uplevel 1 [list [:origin] eval [list ::set :$varname] ]
+ }
+ }
+
:method for {var list body} {
set rendered ""
::foreach $var $list {
uplevel 1 [list ::set $var [set $var]]
+ #uplevel 1 [list ::lassign [set $var] {*}$var]
append rendered [uplevel 1 [list subst $body]]
}
return $rendered
}
+
+ :method ?objvar {obj varname args} {
+ # set args [lassign $args then_script]
+ # append script "\[::set $varname \[$obj eval {set :$varname; puts stderr >>>>\[set :$varname\]}\]\]\n" $then_script
+ uplevel 1 [list :? -ops [list [::nsf::current method] -] \
+ "\[$obj eval {info exists :$varname}\]" {*}$args]
+ }
+
:method ?var {varname args} {
+ set cmd [expr {[string match ":*" $varname]?"\[[:origin] eval {info exists $varname}\]":"\[info exists $varname\]"}]
uplevel 1 [list :? -ops [list [::nsf::current method] -] \
- "\[info exists $varname\]" {*}$args]
+ $cmd {*}$args]
}
:method ? {
{-ops {? -}}
@@ -1083,7 +1261,7 @@
return $preprocessed
}
- :method as_text {} {
+ :public method as_text {} {
set preprocessed [join [:as_list] " "]
set preprocessed [:map $preprocessed sub]
set preprocessed [:map $preprocessed unescape]
@@ -1106,87 +1284,114 @@
set margin [expr {($max-$redux)/2}]
return "[string range $str 0 [expr {$margin-1}]]$placeholder[string range $str end-[expr {$margin+1}] end]"
}
-
+
:method list_structural_features {} {
set entry {{"access": "$access", "host": "$host", "name": "$name", "url": "$url", "type": "$type"}}
set entries [list]
- if {[:info has type ::nx::doc::@package]} {
- set features [list @object @command]
- foreach feature $features {
- set instances [sorted [$feature info instances] name]
- foreach inst $instances {
- set access ""
- set host [:name]
- set name [$inst name]
- set url "[$inst filename].html"
- set type [$feature tag]
- lappend entries [subst $entry]
- }
+ #
+ # TODO: Should I wrap up delegating calls to the originator
+ # entity behind a unified interface (a gatekeeper?)
+ #
+ set features [[:origin] owned_parts]
+ dict for {feature instances} $features {
+ foreach inst $instances {
+ # TODO: @modifier support is specific to the parts of
+ # @object instances. Untangle!
+ set access [expr {[$inst eval {info exists :@modifier}]?[$inst @modifier]:""}]
+ set host ${:name}
+ set name [$inst name]
+ set url "[:filename].html#[string trimleft [$feature name] @]_[$inst name]"
+ set type [$feature name]
+ lappend entries [subst $entry]
}
- } elseif {[:info has type ::nx::doc::@object]} {
- # TODO: fix support for @object-method!
- set features [list @method @param]
- foreach feature $features {
- if {[info exists :$feature]} {
- set instances [sorted [:$feature] name]
- foreach inst $instances {
- set access [expr {[info exists :@modifier]?[:@modifier]:""}]
- set host [:name]
- set name [$inst name]
- set url "[:filename].html#[$feature tag]_[$inst name]"
- set type [$feature tag]
- lappend entries [subst $entry]
- }
- }
- }
- } elseif {[:info has type ::nx::doc::@command]} {
- set features @command
- foreach feature $features {
- if {[info exists :$feature]} {
- set instances [sorted [set :$feature] name]
- foreach inst $instances {
- set access ""
- set host ${:name}
- set name [$inst name]
- set url "[:filename].html#[$feature tag]_[$inst name]"
- set type [$feature tag]
- lappend entries [subst $entry]
- }
- }
- }
}
return "\[[join $entries ,\n]\]"
}
-
- #
- # TODO: This should turn into a hook, the output
- # specificities should move in a refinement of TemplateData, e.g.,
- # DefaultHtmlTemplateData or the like.
- #
-
+
+ # :method get_navigable_features {} {
+ # set features [[:origin] owned_parts]
+ # dict for {feature instances} $features {
+
+ # }
+ # }
+
:method code {{-inline true} script} {
return [expr {$inline?"$script
":"
$script"}] } - :method link {entity_type args} { - set id [$entity_type id {*}$args] - if {![::nsf::is object $id]} return; + :method link {tag names} { + #puts stderr "RESOLVING tag $tag names $names" + set tagpath [split [string trimleft $tag @] .] + lassign [Tag normalise $tagpath $names] err res + if {$err} { + #puts stderr RES=$res + return "?"; + } + lassign [Tag find -all -strict {*}$res] err path + if {$err || $path eq ""} { + #puts stderr "FAILED res $path (err-$err-id-[expr {$path eq ""}])" + return "?"; + } + + set path [dict create {*}$path] + #puts stderr PATH=$path + set pathnames [dict values $path] + set entities [dict keys $path] + set id [lindex $entities end] + set top_entity [lindex $entities 0] + # puts stderr RESOLPATH([$id info class])=$path set pof "" - if {[$id eval {info exists :partof}]} { - set pof "[[$id partof] name]#" - set filename [[$id partof] filename] - } else { - set filename [$id filename] + if {$top_entity ne $id} { + set pof "[$top_entity name]#" + set pathnames [lrange $pathnames 1 end] + set entities [lrange $entities 1 end] } - return "$pof[$id name]" + + # set filename [$top_entity filename] + # puts stderr ENTITIES=$entities-pof-$pof-filename-$filename---[join $pathnames _] + + # return "$pof[join $pathnames .]" + + return "$pof[join $pathnames .]" } - :method as_text {} { - set pre [next] - set post [string map {"\n\n" "