[:? {[info exists :@return] && [${:@return} spec] ne ""} {<[[${:@return} spec] spec]>} ]
 	    ${:name}
-	    [:parameters]
+	    $paramblock

- [:? {[:has_property interally-called]} { + [:? {[:@syshook]} {
Internally called method, can be redefined. }] [:? {[[[:partof] name] info methods ${:name}] ne "" && Index: library/lib/doc-assets/package.html.tmpl =================================================================== diff -u -r26ce746b45449fbff64f88c6d9e9050a63b89449 -r170cefa7618f2b44f91102711607fc6fa7d12c4f --- library/lib/doc-assets/package.html.tmpl (.../package.html.tmpl) (revision 26ce746b45449fbff64f88c6d9e9050a63b89449) +++ library/lib/doc-assets/package.html.tmpl (.../package.html.tmpl) (revision 170cefa7618f2b44f91102711607fc6fa7d12c4f) @@ -26,7 +26,7 @@

[${class} name]
[${class} print_name -status]

@@ -42,7 +42,8 @@

[${obj} name]
[${obj} print_name -status]

@@ -59,7 +60,8 @@

[$cmd name]
[$cmd print_name -status]

Index: library/lib/doc-assets/status.png =================================================================== diff -u Binary files differ Index: library/lib/doc-assets/status.svg =================================================================== diff -u --- library/lib/doc-assets/status.svg (revision 0) +++ library/lib/doc-assets/status.svg (revision 170cefa7618f2b44f91102711607fc6fa7d12c4f) @@ -0,0 +1,405 @@ + + + + Index: library/lib/doc-tools.tcl =================================================================== diff -u -r5d5f67b7b4a9806e10419e44efdcfe724bfcff9b -r170cefa7618f2b44f91102711607fc6fa7d12c4f --- library/lib/doc-tools.tcl (.../doc-tools.tcl) (revision 5d5f67b7b4a9806e10419e44efdcfe724bfcff9b) +++ library/lib/doc-tools.tcl (.../doc-tools.tcl) (revision 170cefa7618f2b44f91102711607fc6fa7d12c4f) @@ -95,6 +95,17 @@ return $result } + proc filtered {instances filteredBy} { + set filtered [list] + foreach v $instances { + if {[$v eval [list expr $filteredBy]]} { + lappend filtered $v + } + } + return $filtered + } + + proc sort_by_value {d} { set haystack [list] dict for {key value} $d { @@ -120,14 +131,35 @@ Class create MixinLayer -superclass Class { :attribute {prefix ""} + :public method init {} { + set :active_mixins [dict create] + next + } :public method apply {} { + if {${:active_mixins} ne ""} { + puts stderr "Warning: mixin layer has not been revoked!" + set :active_mixins [dict create] + } foreach mixin [:info children -type [current class]::Mixin] { set base "${:prefix}::[namespace tail $mixin]" if {[::nsf::isobject $base]} { - set scope [expr {[$mixin scope] eq "object" && [$base info is class]?"class-object":""}] + set scope [expr {[$mixin scope] eq "object" && \ + [$base info is class]?"class-object":""}] + dict lappend :active_mixins $base $mixin $base {*}$scope mixin add $mixin } + } } + + :public method revoke {} { + dict for {base mixins} ${:active_mixins} { + foreach m $mixins { + set scope [expr {[$m scope] eq "object" && \ + [$base info is class]?"class-object":""}] + $base {*}$scope mixin delete $m + } + } + set :active_mixins [dict create] } Class create [current]::Mixin -superclass Class { @@ -285,19 +317,9 @@ } :method createOrConfigure {id args} { - # puts stderr "createOrConfigure id $id" - # This method handles verifies whether an entity object based on - # the given id exists. If so, it returns the resolved name. If - # not, it provides for generating an object with the precomputed - # id for the first time! - # - # @param id The identifier string generated beforehand - # @return The identifier of the newly generated or resolved entity object - # @see {{@method id}} namespace eval $id {} if {[::nsf::isobject $id]} { $id configure {*}$args - # return $id } else { :create $id {*}$args } @@ -432,11 +454,11 @@ [$value info has type ${:part_class}]} { return $value } - # puts stderr "NEWWWWWW ${:part_class} new \ - # -name [lindex $value 0] \ - # -partof $domain \ - # -part_attribute [current] \ - # -@doc [lrange $value 1 end]" + # puts stderr "NEWWWWWW ${:part_class} new \ + # -name [lindex $value 0] \ + # -partof $domain \ + # -part_attribute [current] \ + # -@doc [lrange $value 1 end]" return [${:part_class} new \ -name [lindex $value 0] \ -partof $domain \ @@ -467,6 +489,20 @@ } } + ::nx::MetaSlot create SwitchAttribute -superclass ::nx::Attribute { + :public method init args { + set :defaultmethods [list get get] + next + } + :public method get {obj prop} { + set def [expr {[info exists :default]?${:default}:0}] + if {[$obj eval [list set :$prop]] == $def} { + return [::nsf::setvar $obj $prop [expr {!$def}]] + } + return [next] + } + } + Class create Entity { # # Entity is the base class for the documentation classes @@ -482,9 +518,14 @@ next [list [list @doc:optional __initcmd:initcmd,optional]] } + :class-object attribute current_project:object,type=::nx::doc::@project,allowempty + :public forward current_project [current] %method + :attribute partof:object,type=::nx::doc::StructuredEntity :attribute part_attribute:object,type=::nx::doc::PartAttribute + :attribute pdata + :public method get_upward_path { -relative:switch {-attribute {set :name}} @@ -494,22 +535,33 @@ 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]" - + if {[info exists :partof] && [${: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 @deprecated:boolean -slotclass ::nx::doc::SwitchAttribute { + set :default 0 + } + :attribute @stashed:boolean -slotclass ::nx::doc::SwitchAttribute { + set :default 0 + } + :attribute @c-implemented:boolean -slotclass ::nx::doc::SwitchAttribute { + set :default 0 + } + + # :attribute @properties -slotclass ::nx::doc::PartAttribute + :public method @property {props} { + foreach prop $props { + :@$prop + } + } + :attribute @use { :public method assign {domain prop value} { # @command nx @@ -565,51 +617,19 @@ return [current] } - :method has_property {prop} { - if {![info exists :@properties]} {return 0} - expr {$prop in ${:@properties}} - } - - # @method _doc - # - # The method _doc can be use to obtain the value of the documentation - # from another doc entity. This should avoid redundant documentation pieces. - :method _doc {doc use what value} { - if {$@doc ne ""} {return $doc} - if {$use ne ""} { - foreach thing {@command @object} { - set docobj [$thing id $use] - if {[::nsf::isobject $docobj]} break - } - if {[::nsf::isobject $docobj]} { - if {![$docobj eval [list info exists :$what]]} {error "no attribute $what in $docobj"} - set names [list] - foreach v [$docobj $what] { - if {[$v name] eq $value} {return [$v @doc]} - lappend names [$v name] - } - error "can't use $use, no $what with name $value in $docobj (available: $names)" - } else { - error "can't use $use, no documentation object $docobj" - } + :public method as_list {} { + if {[info exists :@doc] && ${:@doc} ne ""} { + set non_empty_elements [lsearch -all -not -exact ${:@doc} ""] + return [lrange ${:@doc} [lindex $non_empty_elements 0] [lindex $non_empty_elements end]] } } - # @method text + # @method as_text # # text is used to access the content of doc of an Entity, and # performs substitution on it. The substitution is not essential, # but looks for now convenient. - # - :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]] - } - } - :public method as_text {} { set doc [list] set lines [:as_list] @@ -628,6 +648,7 @@ Class create StructuredEntity -superclass Entity { + :public method part_attributes {} { set slots [:info lookup slots] set attrs [list] @@ -637,18 +658,11 @@ } 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]} { dict set r $s [sorted [:$accessor] name] } @@ -757,6 +771,17 @@ } } + :method destroy {} { + foreach {attr part_class} [:part_attributes] { + #$part_class class-object mixin add [current class]::Containable + if {[$part_class eval {info exists :container}] && \ + [$part_class container] eq [current]} { + $part_class eval {unset :container} + } + } + next + } + :public method register {containable:object,type=::nx::doc::Entity} { set tag [[$containable info class] tag] if {[:info lookup methods -source application "@$tag"] ne ""} { @@ -766,6 +791,10 @@ } Tag create @project -superclass ContainerEntity { + + :attribute sandbox:object,type=::nx::doc::Sandbox + :attribute sources + :attribute url :attribute license :attribute creationdate @@ -778,6 +807,29 @@ :attribute @package -slotclass ::nx::doc::PartAttribute { set :part_class ::nx::doc::@package } + + :public method destroy {} { + # + # TODO: Using the auto-cleanup feature in [Test case ...] does + # not respect explicit destroy along object relations. Turn the + # test environment more passive by checking for the existance + # before calling destroy! + # + if {[::nsf::isobject ${:sandbox}]} { + ${:sandbox} destroy + } + :current_project "" + next + } + + :method init {} { + # + # TODO: the way we provide the project as a context object to + # all entities is not easily restricted. Review later ... + # + :current_project [current]; # sets a per-class-object variable on Entity! + next + } } # @@ -920,16 +972,21 @@ # and/or generalisable: For instance, is the scope # requested (from the part_attribute) applicable to the # partof object, which is the object behind [$domain name]? - if {[info exists :scope] && - ![::nsf::is ${:scope} [$domain name]]} { - error "The entity '[$domain name]' does not qualify as '${:scope}'" - } + + # TODO: disable for the moment ... how to rewrite to fit + # the sandboxed environment? + # if {[info exists :scope] && + # ![::nsf::is ${:scope} [$domain name]]} { + # error "The entity '[$domain name]' does not qualify as '${:scope}'" + # } next } } :method inherited {member} { - if {[${:name} info is class]} { + set prj [:current_project] + set box [$prj sandbox] + if {[$box eval [list ::nsf::is class ${:name}]]} { set inherited [dict create] foreach c [lreverse [${:name} info heritage]] { set entity [[::nsf::current class] id $c] @@ -959,6 +1016,9 @@ # PartTag create @method \ -superclass StructuredEntity { + :attribute @syshook:boolean -slotclass ::nx::doc::SwitchAttribute { + set :default 0 + } :attribute {@modifier public} -slotclass ::nx::doc::PartAttribute :attribute @parameter -slotclass ::nx::doc::PartAttribute { set :part_class ::nx::doc::@param @@ -1081,6 +1141,9 @@ set comment "Perfect match" } else { set comment "actual parameter: $actualParams" + if {[info exists :pdata]} { + lappend :pdata status mismatch + } } append comment "
Syntax: obj ${:name} $syntax" } else { @@ -1200,7 +1263,7 @@ interp alias {} ::nx::doc::@acrfirst {} ::nx::doc::@glossary namespace export CommentBlockParser @command @object @class @package \ - @project @method @attribute @parameter @ + @project @method @attribute @parameter @ MixinLayer } @@ -1398,7 +1461,12 @@ set preprocessed [join [:as_list] " "] set preprocessed [:map $preprocessed] set preprocessed [:unescape $preprocessed] - return [subst $preprocessed] + # TODO: For now, we take a passive approach: Some docstrings + # might fail because they contain substitution characters + # ($,[]); see nx.tcl + # ... + catch {set preprocessed [subst $preprocessed]} msg + return $preprocessed } } @@ -1472,8 +1540,8 @@ # 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 + # :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", @@ -1484,8 +1552,23 @@ :class-object attribute rendered_entity:object,type=::nx::doc::Entity :public forward rendered_entity [current] %method - :public forward print_name %current name + # :public forward print_name %current name + :public method print_name {-status:switch} { + set status_mark "" + if {$status} { + set cls "" + if {[info exists :pdata]} { + set cls [expr {[dict exists ${:pdata} status]?\ + [dict get ${:pdata} status]:""}] + } else { + set cls "extra" + } + set status_mark " " + } + return "${:name}$status_mark" + } + :method fit {str max {placeholder "..."}} { if {[llength [split $str ""]] < $max} { return $str; @@ -1537,7 +1620,7 @@ 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 @@ -1814,177 +1897,818 @@ } # -# post processor for initcmds and method bodies +# sandboxing # -namespace eval ::nx { - namespace import -force ::nx::doc::* - ::nx::Object create doc { - :method log {msg} { - puts stderr "[current]->[uplevel 1 [list ::nsf::current method]]: $msg" +namespace eval ::nx::doc { + namespace import -force ::nx::* + Class create Sandbox { + + :public class-object method type=in {name value arg} { + if {$value ni [split $arg |]} { + error "The value '$value' provided for parameter $name not permissible." + } + return $value } - # @method process + :public class-object method type=fqn {name value} { + if {[string first "::" $value] != 0} { + error "The value '$value' must be a fully-qualified Tcl name." + } + return $value + } + + :public class-object method type=fpathtype {name value arg} { + # + # Note: We might receive empty strings in case of [eval]s! + # + set pt [file pathtype $value] + if {$value ne "" && $pt ne $arg} { + error "The filepath '$value' must be $arg, rather than $pt." + } + return $value + } + + :public class-object method type=nonempty {name value} { + if {$value eq ""} { + error "An empty value is not allowed for parameter '$name'." + } + return $value + } + + :protected attribute {current_packages "*"} + :attribute {permissive_pkgs:multivalued "*"} { + set :incremental 1 + } + # - # There is a major distinction: Is the entity the comment block is - # referring to given *extrinsically* (to the comment block) or - # *intrinsically* (as a starting tag). - # - # a. extrinsic: 'thing' is a valid class or object name - # b. intrinsic: 'thing' is a arbitrary string block describing - # a script. - # - :public method process {{-noeval false} thing args} { - # 1) in-situ processing: a class object - if {[::nsf::isobject $thing]} { - if {[$thing eval {info exists :__initcmd}]} { + # some callbacks invoked from within the sandbox interp + # + + :public method at_source {filepath} { + set cpackage [lindex ${:current_packages} end] + if {$cpackage in ${:permissive_pkgs}} { + lappend :source $cpackage $filepath + } + } + + :public method at_register_package {pkg_name} { + lappend :current_packages [string tolower $pkg_name] + } + :public method at_deregister_package {} { + set :current_packages [lrange ${:current_packages} 0 end-1] + } + # [list ->status:in,arg=complete|missing|prototype|mismatch,slot=[current] missing] + :public method at_register_command [list \ + name:fqn,slot=[current] \ + ->cmdtype:in,arg=object|proc|method,slot=[current] \ + ->source:fpathtype,arg=absolute,slot=[current] \ + {->nsexported:boolean 0} \ + {->nsimported:boolean 0} \ + ->docstring:optional,nonempty,slot=[current] \ + ] { + # peek the currently processed package (if any) + set storable_vars [info vars >*] + set cpackage [lindex ${:current_packages} end] + if {$cpackage in ${:permissive_pkgs}} { + dict set :registered_commands $name package $cpackage + foreach svar $storable_vars { + dict set :registered_commands $name [string trimleft $svar >] [set $svar] + } + } + } + + :public method at_deregister_command [list name:fqn,slot=[current]] { + set cpackage [lindex ${:current_packages} end] + if {$cpackage in ${:permissive_pkgs}} { + dict unset :registered_commands $name + } + } + + :public method init args { + :do { + + # + # hide selected built-in Tcl commands and put simple + # forwarding proxies in place ... + # + # TODO: refactor the proxy handling ... + # + interp hide "" proc + interp hide "" namespace + interp hide "" source + interp hide "" load + interp hide "" package + interp hide "" auto_import + + interp invokehidden "" proc ::proc args { + #set ns [uplevel [list interp invokehidden "" namespace current]] + uplevel [list interp invokehidden "" proc {*}$args] + } + + proc ::namespace args { + #set ns [uplevel [list interp invokehidden "" namespace current]] + #interp invokehidden "" -namespace $ns namespace {*}$args + uplevel [list interp invokehidden "" namespace {*}$args] + } + + proc ::source args { + uplevel [list interp invokehidden "" source {*}$args] + } + + proc ::load args { + # set ns [uplevel [list interp invokehidden "" namespace current]] + # interp invokehidden "" -namespace $ns load {*}$args + uplevel [list interp invokehidden "" load {*}$args] + + } + + proc ::package args { + # set ns [uplevel [list interp invokehidden "" namespace current]] + # interp invokehidden "" -namespace $ns package {*}$args + uplevel [list interp invokehidden "" package {*}$args] + } + + proc ::auto_import args { + # set ns [uplevel [list interp invokehidden "" namespace current]] + # interp invokehidden "" -namespace $ns auto_import {*}$args + uplevel [list interp invokehidden "" auto_import {*}$args] + } + + namespace eval ::nx::doc { - :analyze_initcmd [expr {[::nsf::is class $thing]?"@class":"@object"}] $thing [$thing eval {set :__initcmd}] - } - } elseif {![catch {package present $thing} msg]} { - # For tcl packages, we assume that the package is sourceable - # in the current interpreter. - set i [interp create] - set cmd [subst -nocommands { - package req nx::doc - namespace import -force ::nx::*; - ::nx::Class create SourcingTracker { - :method create args { - set obj [next]; - #[::nsf::current class] eval { - # if {![info exists :scripts([info script])]} { - #dict create :scripts - #dict set :scripts [info script] objects - # } - #} - #puts stderr "dict lappend :scripts([info script]) objects [current]" - [::nsf::current class] eval [list dict set :scripts [info script] objects \$obj _] - return \$obj + proc is_exported {name} { + # + # ! ISSUE: The built-in [namespace] command is hidden in our + # ! sandbox interp when [is_exported] is used during a + # ! 2pass!!!! + # + set calling_ns [uplevel [list interp invokehidden "" namespace current]] + set ns [interp invokehidden "" namespace current]::_?_ + interp invokehidden "" namespace eval $ns \ + [list interp invokehidden "" namespace import -force $name] + set is [expr {[info commands ${ns}::[interp invokehidden "" namespace tail $name]] ne ""}] + interp invokehidden "" namespace delete $ns + return $is + } + + + proc __trace_pkg {} { + + #puts stderr ">>> INIT [package names]" + # ::interp hide "" source + ::proc ::source {path} { + set ns [uplevel [list namespace current]] + if {[file tail $path] ne "pkgIndex.tcl"} { + ::nx::doc::__at_source [file normalize $path] + } + uplevel [list interp invokehidden "" source $path] } + + proc list_commands {{parent ""}} { + set ns [dict create] + #set cmds [string trim "[join [info commands ${parent}::*] \" 0 \"] 0" 0] + # + # Note: We trigger a [namespace import] for the + # currently processed namespace before requesting the + # command list in order to have the auto_load feature + # initialise commands otherwise found too late, + # i.e. after having computed the [info + # commands] snapshot! + # +# namespace eval ::nx::doc::__x [list namespace import -force ${parent}::*] + set cmds [info commands ${parent}::*] + + set exported [list] + foreach cmd $cmds { + dict set ns ::[string trimleft $parent :] $cmd [is_exported $cmd] + +#[expr {[info commands ::nx::doc::__x::[namespace tail $cmd]] ne ""}] + } + + foreach nsp [namespace children ${parent}::] { + set ns [dict merge $ns [list_commands ${nsp}]] + } + return $ns + } + + + ::proc ::load args { + + set ns [uplevel [list namespace current]] + + # + # pre-state + # + # set pre_loaded [dict values \ + # [dict create {*}[concat {*}[info loaded ""]]]] + set pre_loaded [lreverse [concat {*}[info loaded ""]]] + set pre [::nx::doc::list_commands] + set pre_commands [dict create {*}[concat {*}[dict values $pre]]] + set pre_namespaces [dict keys $pre] + + interp invokehidden "" -namespace $ns load {*}$args + + # + # post-state + # + #set post_loaded [dict create {*}[concat {*}[info loaded ""]]] + set post_loaded [lreverse [concat {*}[info loaded ""]]] + set post [::nx::doc::list_commands] + set post_commands [dict create {*}[concat {*}[dict values $post]]] + set post_namespaces [dict keys $post] + + # + # deltas + # + set delta_commands [dict remove $post_commands {*}[dict keys $pre_commands]] + + set delta_namespaces [dict keys [dict remove [dict create {*}"[join $post_namespaces " _ "] _"] {*}$pre_namespaces]] + + set delta_pkg [dict remove \ + [dict create {*}$post_loaded] \ + [dict keys [dict create {*}$pre_loaded]]] + + #puts stderr "DELTAS pkg $delta_pkg" + #puts stderr "DELTAS namespace $delta_namespaces" + #puts stderr "DELTAS commands $delta_commands" + + lassign $delta_pkg pkg_name filepath + set filepath [file normalize $filepath] + foreach {cmd isexported} $delta_commands { + ::nx::doc::__at_register_command $cmd \ + ->cmdtype proc \ + ->source $filepath \ + ->nsexported $isexported + } + } + + ::proc ::package {subcmd args} { + set ns [uplevel [list namespace current]] + set was_registered 0 + switch -glob -- $subcmd { + ifneeded { + lassign $args pkg_name version script + append wrapped_script "::nx::doc::__at_register_package $pkg_name;\n" $script "\n::nx::doc::__at_deregister_package;" + set args [list $pkg_name $version $wrapped_script] + } + } + interp invokehidden "" -namespace $ns package $subcmd {*}$args + # uplevel [list interp invokehidden "" package $subcmd {*}$args] +# if {$was_registered} { +# ::nx::doc::__at_deregister_package +# } + } + + # + # Note that we have to wrap up Tcl's auto_import due to + # our practise of [namespace import]'ing application + # namespaces to verify whether commands are actually + # exported; see list_commands. Currently, we escape to a + # generic package called TCL_LIBRARY to filter out + # commands lazily acquired through the auto_load + # mechanism, triggered by the [namespace import] + # probing. + # + #::interp hide "" auto_import + ::proc ::auto_import {pattern} { + set ns [uplevel [list namespace current]] + ::nx::doc::__at_register_package TCL_LIBRARY; + interp invokehidden "" -namespace $ns auto_import $pattern + ::nx::doc::__at_deregister_package; + } } - ::nx::Object mixin add SourcingTracker - package forget $thing - package req $thing - ::nx::Object mixin delete SourcingTracker - #puts stderr sourced_scripts=[SourcingTracker eval {dict keys \${:scripts}}] - dict for {script entities} [SourcingTracker eval {set :scripts}] { - doc process \$script \$entities + proc __init {} { + # 1) provide for tracing NSF objects + if {[info commands ::nsf::configure] ne "" && \ + [::nsf::configure objectsystem] ne ""} { + ::nsf::configure keepinitcmd true; + + rename ::nsf::method ::nsf::_%&method + ::interp invokehidden "" proc ::nsf::method { + object + args + } { + set handle [uplevel [list ::nsf::_%&method $object {*}$args]] + if {$handle ne ""} { + ::nx::doc::__at_register_command $handle \ + ->cmdtype method \ + ->source [file normalize [info script]] + } + return $handle + } + + rename ::nsf::alias ::nsf::_%&alias + ::interp invokehidden "" proc ::nsf::alias { + args + } { + set handle [uplevel [list ::nsf::_%&alias {*}$args]] + if {$handle ne ""} { + ::nx::doc::__at_register_command $handle \ + ->cmdtype method \ + ->source [file normalize [info script]] + } + return $handle + } + + + + rename ::nsf::createobjectsystem ::nsf::_%&createobjectsystem + ::interp invokehidden "" proc ::nsf::createobjectsystem { + rootclass + rootmclass + args + } { + uplevel [list ::nsf::_%&createobjectsystem $rootclass $rootmclass {*}$args] + foreach r [list $rootclass $rootmclass] { + ::nx::doc::__at_register_command $r \ + ->cmdtype object \ + ->source [file normalize [info script]] \ + ->nsexported [::nx::doc::is_exported $r] \ + {*}[expr {[::nsf::existsvar $r __initcmd] && [::nsf::setvar $obj __initcmd] ne ""?[list ->docstring [::nsf::setvar $r __initcmd]]:[list]}] + } + } + + + array set sysmeths [concat {*}[lassign {*}[::nsf::configure objectsystem] rootclass rootmclass]] + set rootns [namespace qualifier $rootmclass] + $rootmclass $sysmeths(-class.create) ${rootns}::__Tracer + ::nsf::method ${rootns}::__Tracer \ + -public $sysmeths(-class.create) {name args} { + set obj [::nsf::next]; + ::nx::doc::__at_register_command $obj \ + ->cmdtype object \ + ->source [file normalize [info script]] \ + ->nsexported [::nx::doc::is_exported $obj] \ + {*}[expr {[::nsf::existsvar $obj __initcmd] && [::nsf::setvar $obj __initcmd] ne ""?[list ->docstring [::nsf::setvar $obj __initcmd]]:[list]}] + return $obj + } + # ISSUE: yields -> bad relationtype "mixin": must be + # object-mixin, class-mixin, object-filter, + # class-filter, class, superclass, or rootclass + # -> ::nsf::mixin defaults to "mixin" instead of "class-mixin" + # ::nsf::mixin $rootmclass ::nsf::__Tracer + ::nsf::relation $rootmclass class-mixin ${rootns}::__Tracer + + } + # 2) provide for tracing Tcl procs declared at "sourcing time" -> [proc] + #::interp hide "" proc + ::interp invokehidden "" proc ::proc {name arguments body} { + set ns [uplevel [list namespace current]] + interp invokehidden "" -namespace $ns proc $name $arguments $body + set fqn $name + if {[string first "::" $name] != 0} { + set fqn [string trimright $ns :]::$name + } + if {$arguments eq "" && $body eq ""} { + ::nx::doc::__at_deregister_command $fqn + } else { + ::nx::doc::__at_register_command $fqn \ + ->cmdtype proc \ + ->source [file normalize [info script]] \ + ->nsexported [::nx::doc::is_exported $fqn] \ + ->docstring $body + } + + } + # 3) provide for tracing commands namespace-imported at "sourcing time" + #::interp hide "" namespace + ::interp invokehidden "" proc ::namespace {subcmd args} { + set ns [uplevel [list interp invokehidden "" namespace current]] + switch -glob -- $subcmd { + imp* { + foreach pattern $args { + if {[string match "-*" $pattern]} continue; + foreach cmd [info commands $pattern] { + if {![::nx::doc::is_exported $cmd]} continue; + set type [expr {[info commands "::nsf::isobject"] ne "" &&\ + [::nsf::isobject $cmd]?"object":"proc"}] + + set imported_name [string trimright $ns :]::[namespace tail $cmd] + ::nx::doc::__at_register_command $imported_name \ + ->cmdtype $type \ + ->source [file normalize [info script]] \ + ->nsexported [::nx::doc::is_exported $imported_name] \ + ->nsimported 1 + } + } + } + } + interp invokehidden "" -namespace $ns namespace $subcmd {*}$args + } } - - }] - interp eval $i $cmd - return $i - } elseif {[file isfile $thing]} { - # 3) alien script file - set script "" - if {[file readable $thing]} { - # a) process the target file - set fh [open $thing r] - if {[catch {append script [read $fh]} msg]} { - catch {close $fh} - :log "error reading the file '$thing', i.e.: '$msg'" - } - catch {close $fh} } - # b) verify the existence of an *.nxd companion file - set rootname [file rootname $thing] + } + ::interp alias ${:interp} ::nx::doc::__at_register_command \ + "" [current] at_register_command + ::interp alias ${:interp} ::nx::doc::__at_deregister_command \ + "" [current] at_deregister_command + ::interp alias ${:interp} ::nx::doc::__at_register_package \ + "" [current] at_register_package + ::interp alias ${:interp} ::nx::doc::__at_deregister_package \ + "" [current] at_deregister_package + ::interp alias ${:interp} ::nx::doc::__at_source \ + "" [current] at_source + next + } + :protected attribute {interp ""}; # the default empty string points to the current interp + + :attribute registered_commands + + :public method get_companions {} { + set companions [dict create] + dict for {cmd props} ${:registered_commands} { + dict with props { + # $source, $package + dict set companions $source $package + } + } + set scripts [list] + dict for {source pkg} $companions { + set rootname [file rootname $source] + set dir [file dirname $source] set companion $rootname.nxd - if {[file isfile $companion] && [file readable $companion]} { - set fh [open $companion r] - if {[catch {append script "\n\n" [read $fh]} msg]} { + set srcs [dict create {*}"[join [list $source $rootname.nxd [file join $dir $pkg].nxd] " _ "] _"] + foreach src [dict keys $srcs] { + if {![file isfile $src] || ![file readable $src]} continue; + if {[file extension $src] eq [info sharedlibextension]} continue; + set fh [open $src r] + if {[catch {lappend scripts [read $fh]} msg]} { catch {close $fh} :log "error reading the file '$thing', i.e.: '$msg'" } catch {close $fh} } - - if {$script eq ""} { - :log "script empty, probaly file '$thing' is not readable" + } + return $scripts + } + + :public method get_registered_commands { + -exported:switch + -types + -not:switch + nspatterns:optional + } { + if {[info exists nspatterns]} { + set opts [join $nspatterns |] + set nspatterns "^($opts)::\[^\:\]+\$" + } + dict filter ${:registered_commands} script {cmd props} { + dict with props { + expr {[expr {[info exists nspatterns]?[expr {[regexp -- $nspatterns $cmd _] != $not}]:1}] && \ + [expr {$exported?[expr {$nsexported == $exported}]:1}] && \ + [expr {[info exists types]?[expr {$cmdtype in $types}]:1}]} } + } + #lsearch -inline -all -regexp $additions {^::nsf::[^\:]+$}] + } - doc analyze -noeval $noeval $script {*}$args - puts stderr FILE=$thing--[file readable $thing]-COMPANION=$companion--[file readable $companion]-ANALYZED-[string length $script]bytes + +# :forward do ::interp %1 {% set :interp} + :public method do {script} { + ::interp eval ${:interp} $script + } + + :public method destroy {} { + # + # TODO: Why am I called twice in doc.test? Because of the test + # enviroment (the auto-cleanup feature?) + # + # puts stderr "SELF [current object] interp ${:interp}" + # ::nsf::__db_show_stack + if {${:interp} ne ""} { + if {[interp exists ${:interp}]} { + interp delete ${:interp} + } } else { - # 4) we assume a string block, e.g., to be fed into eval - set i [interp create] - set cmd [subst { - package req nx::doc - namespace import -force ::nx::doc::* - doc analyze -noeval $noeval [list $thing] - }] - interp eval $i $cmd - #interp delete $i - return $i + :do { + if {[info commands ::nsf::configure] ne ""} { + ::nsf::configure keepinitcmd false; + array set sysmeths [concat {*}[lassign {*}[::nsf::configure objectsystem] rootclass rootmclass]] + # TODO: some cleanup is only needed if __init has been called + # (which is not always the case). refactor the code + # accordingly. + set rootns [namespace qualifier $rootmclass] + if {[::nsf::isobject ${rootns}::__Tracer]} { + ${rootns}::__Tracer $sysmeths(-object.destroy) + ::nsf::relation $rootmclass class-mixin {} + } + if {[info commands ::nsf::_%&createobjectsystem] ne ""} { + rename ::nsf::_%&createobjectsystem ::nsf::createobjectsystem + } + unset rootns + } + rename ::proc "" + interp expose "" proc + rename ::namespace "" + interp expose "" namespace + rename ::source "" + interp expose "" source + rename ::load "" + interp expose "" load + rename ::package "" + interp expose "" package + rename ::auto_import "" + interp expose "" auto_import + + proc ::nx::doc::__at_register_command {} {} + proc ::nx::doc::__at_deregister_command {} {} + proc ::nx::doc::__at_register_package {} {} + proc ::nx::doc::__at_deregister_package {} {} + } } + next } + } + namespace export Sandbox +} +# +# post processor for initcmds and method bodies +# +namespace eval ::nx { + + namespace import -force ::nx::doc::* + + MixinLayer create processor -prefix ::nx::doc { + namespace eval ::nx::doc { + namespace eval ::nx::doc::MixinLayer { + namespace export Mixin + } + namespace import -force ::nx::doc::MixinLayer::* + namespace export Mixin + } - :public method analyze {{-noeval false} script {additions ""}} { - # NOTE: This method is to be executed in a child/ slave - # interpreter. - if {!$noeval} { - uplevel #0 [list namespace import -force ::nx::doc::*] - set pre_commands [:list_commands] - uplevel #0 [list eval $script] - set post_commands [:list_commands] - if {$additions eq ""} { - set additions [dict keys [dict remove [dict create {*}"[join $post_commands " _ "] _"] {*}$pre_commands]] - } else { - set additions [dict keys [dict get $additions objects]] + namespace import -force ::nx::doc::* + + Mixin create [current]::Entity { + :public method get_command_name {} { + return ${:name} + } + :public method init args { + next + set prj [:current_project] + if {$prj ne ""} { + set box [$prj sandbox] + set cmdname [:get_command_name] + if {[$box eval [concat dict exists \${:registered_commands} $cmdname]]} { + :pdata [$box eval [concat dict get \${:registered_commands} $cmdname]] + } } - # puts stderr ADDITIONS=$additions + [[current class] info parent] at_processed [current] } - set blocks [:comment_blocks $script] - # :log "blocks: '$blocks'" - # 1) eval the script in a dedicated interp; provide for - # recording script-specific object additions. - # set failed_blocks [list] - foreach {line_offset block} $blocks { - # 2) process the comment blocks, however, fail gracefully here - # (most blocks, especially in initcmd and method blocks, are - # not qualified, so they are set to fail. however, record the - # failing ones for the time being - set cbp [::nx::doc::CommentBlockParser process $block] - # TODO: How to handle contingent (recoverable) conditions here? - # if {[catch {::nx::doc::CommentBlockParser process $block} msg]} { - # if {![InvalidTag behind? $msg] && ![StyleViolation behind? $msg] && ![MissingPartofEntity behind? $msg]} { - # if {[Exception behind? $msg]} { - # ::return -code error -errorinfo $::errorInfo "[$msg info class]->[$msg message]" - # # error [$msg info class]->[$msg message] - # } - # ::return -code error -errorinfo $::errorInfo $msg - # } - # } + } + + Mixin create [current]::@method -superclass [current]::Entity { + :method get_command_name {} { + return ::nsf::classes::[string trimleft [[:partof] name] :]::${:name} } - # 3) process the recorded object additions, i.e., the stored - # initcmds and method bodies. - foreach addition $additions { - # TODO: for now, we skip over pure Tcl commands and procs - if {![::nsf::is object $addition]} continue; - set kind [expr {[::nsf::is class $addition]?"@class":"@object"}] - #puts stderr "ADDITION :process [namespace origin $addition]" - if {[$addition eval {info exists :__initcmd}]} { - :analyze_initcmd $kind $addition [$addition eval {set :__initcmd}] + } + + # + # mixin layer interface + # + + :class-object method apply {} { + unset -nocomplain :processed_entities + next + } + + :class-object method revoke {} { + next + if {[info exists :processed_entities]} { + return [dict keys ${:processed_entities}] + } + } + + :public class-object method at_processed {entity} { + dict set :processed_entities $entity _ + } + + # + # processor interface + # + + :class-object method log {msg} { + puts stderr "[current]->[uplevel 1 [list ::nsf::current method]]: $msg" + } + + :public class-object method process {-sandboxed:switch {-type project} thing} { + if {$type ne "project"} { + # TODO: Fix the naming requirements ... + set project [@project new -name "_%@"] + $project sources [list $type $thing] + } else { + set project $thing + } + + $project sandbox [Sandbox new -interp [expr {$sandboxed?[interp create]:""}]] + set sources [dict create] + foreach {type name} [$project sources] { + dict lappend sources $type $name + } + #puts stderr "SOURCES $sources" + dict for {type instances} $sources { + :[current method]=$type $project $instances + } + return $project + } + + :protected class-object method process=package {project pkgs} { + set box [$project sandbox] + $box permissive_pkgs $pkgs + set 1pass "" + foreach pkg $pkgs { + if {[catch {package present $pkg} _]} { + error "Tcl package '$pkg' cannot be found." } + append 1pass "package req $pkg\n" + } - # TODO: Note, the CommentBlockParser should operate on the - # level of a single block, not entire initcmd and method body - # scripts. The process=@object ressembles some ::nx::doc - # methods, so relocated and call the parser from within. - set entity [@ $kind $addition] - #puts stderr ":process=$kind $entity" - :process=$kind $entity + # + # a) 1-pass: requiring the packages first will provide + # all dependencies (also those not to be documented). + # + $box do "::nx::doc::__trace_pkg; $1pass" + + # + # b) 2-pass: [source] will re-evaluate the package scripts + # (note, [load]-based extension packages are not covered by this!) + #" + if {[$box eval {info exists :source}]} { + foreach {pkg src} [$box eval {set :source}] { + # + # TODO: 2-pass [source]s should not trigger transitive [source]s. we + # have flattened the relevant [source] hierarchy in the + # 1-pass. + # + append 2pass \ + "::nx::doc::__at_register_package $pkg;\n" \ + "source $src;\n" \ + "::nx::doc::__at_deregister_package;\n" + } + $box do "::nx::doc::__init; $2pass" } + + set scripts [$box get_companions] + set provided_entities [list] + foreach script $scripts { + lappend provided_entities {*}[:readin $script] + } + + # output + # 1. absent entities (doc[yes]->program[no]) + # => all doc entities without pdata +# puts stderr "--- $provided_entities" + set present_entities [::nx::doc::filtered $provided_entities {[info exists :pdata]}] + # TODO: the nspatterns should be consumed from the source + # specification and should not be hardcoded here ... review + # later ... + set generated_commands [$box get_registered_commands [list ::nsf ::nx]] + foreach pe $present_entities { + dict unset generated_commands [$pe name] + } +# puts stderr "PRESENT $present_entities" +# puts stderr "ABSENT [::nx::doc::filtered $provided_entities {![info exists :pdata]}]" + # 2. generated entities (doc[no]->program[yes]) + # => all registered_commands without doc entity +# puts stderr "== TO GENERATE == [dict keys $generated_commands]" + dict for {cmd info} $generated_commands { + if {[string match ::nsf::classes::* $cmd]} continue; + if {[string match ::nsf::objects::* $cmd]} continue; + if {[string match *::slot::* $cmd]} continue; + dict with info { + # + # TODO: for now, we assume objects beyond this point + # ... relax later! + # + if {$cmdtype ni [list object proc]} continue; + set kind @command + if {$cmdtype eq "object"} { + set kind [expr {[$box do [list ::nsf::is class $cmd]]?\ + "@class":"@object"}] + } + set entity [@ $kind $cmd] + :process=$kind $project $entity + $entity pdata [lappend info status missing] + } + } } - :method list_commands {{parent ""}} { - set cmds [info commands ${parent}::*] - foreach nsp [namespace children $parent] { - lappend cmds {*}[:list_commands ${nsp}] + :protected class-object method process=source {project filepath} {;} + + :protected class-object method process=eval {project scripts} { + set box [$project sandbox] + # + # 1a) 1pass ... TODO: should tracing be enabled in this scenario? ... + # + foreach script $scripts { + $box do $script } - return $cmds + + # + # 2) 2pass ... + # + $box do [list ::nx::doc::__init] + + foreach script $scripts { + $box do $script + } + # + # 3) documentation processing + # + #puts stderr ">>> CMDS [$box get_registered_commands]" + + # 3a) top-level processing + foreach script $scripts { + :readin $script + } + + # 3b) initcmds, proc bodies ... + + dict for {cmd info} [$box get_registered_commands] { + dict with info { + # + # TODO: for now, we assume objects beyond this point + # ... relax later! + # + if {$cmdtype ne "object"} continue; + set kind [expr {[$box do [list ::nsf::is class $cmd]]?"@class":"@object"}] + if {[info exists docstring]} { + lassign [:readin \ + -docstring \ + -tag $kind \ + -name $cmd \ + -parsing_level 1 \ + $docstring] entity processed_entities + unset docstring + } else { + set entity [@ $kind $cmd] + } + :process=$kind $project $entity + } + } } + + :public class-object method readin { + -docstring:switch + -tag + -name + -partof_entity:object,type=::nx::doc::StructuredEntity + {-parsing_level:integer 0} + script + } { - :public method analyze_line {line} { + set blocks [:comment_blocks $script] + + set first_block 1 + set processed_entities [list] + foreach {line_offset block} $blocks { + array set arguments [list -initial_section context \ + -parsing_level $parsing_level] + + if {$docstring} { + if {[info exists partof_entity]} { + set arguments(-partof_entity) $partof_entity + } + if {![info exists tag] || ![info exists name]} { + error "In docstring mode, provide the tag and the name of + a docstring-owning documentation entity object." + } + if {$first_block} { + # + # TODO: Note that the two "creation procedures" are not + # idempotent; the relative one overwrites description + # blocks of pre-exisiting entities, the freestanding @ + # does not ... fix later when reviewing these parts of the + # program ... + # + set docentity [expr {[info exists partof_entity]?\ + [$partof_entity $tag $name]:[@ $tag $name]}] + set arguments(-partof_entity) $docentity + if {$line_offset <= 1} { + set arguments(-initial_section) description + set arguments(-entity) $docentity + } + } + } + + set args [array get arguments] + lappend args $block + # puts stderr "::nx::doc::CommentBlockParser process {*}$args" + #::nx::doc::Entity mixin add [current]::Entity + :apply + ::nx::doc::CommentBlockParser process {*}$args + lappend processed_entities {*}[:revoke] + set first_block 0 + } + if {$docstring && [info exists arguments(-partof_entity)]} { + return [list $arguments(-partof_entity) $processed_entities] + } else { + return $processed_entities + } + } + + :public class-object method analyze_line {line} { set regex {^[\s#]*#+(.*)$} if {[regexp -- $regex $line --> comment]} { return [list 1 [string trimright $comment]] @@ -1993,7 +2717,7 @@ } } - :public method comment_blocks {script} { + :public class-object method comment_blocks {script} { set lines [split $script \n] set comment_blocks [list] set was_comment 0 @@ -2002,12 +2726,6 @@ 0,1 { set line_offset $line_counter; set comment_block [list]; - # Note, we use [split] here to avoid stumbling over - # uncommented script blocks which contain pairs of curly - # braces which appear scattered over several physical lines - # of code. This avoids "unmatched open brace" failures when - # feeding each physical line to a list command (later, in - # the parsing machinery) lappend comment_block $text} 1,0 {lappend comment_blocks $line_offset $comment_block} 1,1 {lappend comment_block $text} @@ -2024,127 +2742,84 @@ } return $comment_blocks } - - :public method analyze_initcmd {{-parsing_level 1} docKind name initcmd} { - set first_block 1 - set failed_blocks [list] - foreach {line_offset block} [:comment_blocks $initcmd] { - set arguments [list] - if {$first_block} { - set id [@ $docKind $name] - # - # Note: To distinguish between intial comments blocks - # in initcmds and method bodies which refer to the - # surrounding entity (e.g., the object or the method) - # we use the line_offset recorded by the - # comment_blocks() scanner. Later, we plan to use the - # line_offset to compute line pointers for error - # messages. Also, we can use the line offsets of each - # comment block to identify faulty comment blocks. - # - # A acceptance level of <= 1 means that a script - # block must contain the first line of this - # special-purpose comment block either in the very - # first or second script line. - # - if {$line_offset <= 1} { - lappend arguments -initial_section description - lappend arguments -entity $id - } - set first_block 0 - } else { - set initial_section context - } - lappend arguments $block - # TODO: Filter for StyleViolations as >the only< valid case - # for a continuation. Report other issues immediately. What - # about InvalidTag?! - # TODO: Passing $id as partof_entity appears unnecessary, - # clean up the logic in CommentBlockParser->process()!!! - #puts stderr "==== CommentBlockParser process -partof_entity $id {*}$arguments" - set cbp [CommentBlockParser process -parsing_level $parsing_level -partof_entity $id {*}$arguments] - -# if {[catch {CommentBlockParser process -partof_entity $id {*}$arguments} msg]} { -# lappend failed_blocks $line_offset -# } - } - - }; # analyze_initcmd method # TODO: how can I obtain some reuse here when later @class is # distinguished from @object (dispatch along the inheritance # hierarchy?) - :public method process=@class {entity} { - set name [$entity name] + :public class-object method process=@command {project entity} {;} + + :public class-object method process=@class {project entity} { + set name [$entity name] + set box [$project sandbox] # attributes - foreach slot [$name info slots] { - if {[$slot eval {info exists :__initcmd}]} { - set blocks [:comment_blocks [$slot eval {set :__initcmd}]] - foreach {line_offset block} $blocks { - if {$line_offset > 1} break; - set scope [expr {[$slot per-object]?"class-object":"class"}] - set id [$entity @${scope}-attribute [$slot name]] - CommentBlockParser process \ - -parsing_level 2 \ - -partof_entity $entity \ - -initial_section description \ - -entity $id \ - $block - } + foreach slot [$box do [list $name info slots]] { + if {[$box do [list $slot eval {info exists :__initcmd}]]} { + # + # TODO: Here, we eagerly create doc entities, is this an issue? + # Should we mark them for removal if not further processed? + # This might be contradicting to the requirement of + # identifying documented/undocumented program structures. + # + # There are two alternatives: + # -> use a freestanding identity generator (preferred!) + # -> mark the entity for deletion + # + # set id [$entity @${scope}-attribute [$box do [list $slot name]]] + + set scope [expr {[$box do [list $slot per-object]]?"class-object":"class"}] + :readin \ + -partof_entity $entity \ + -docstring \ + -tag @${scope}-attribute \ + -name [$box do [list $slot name]] \ + -parsing_level 2 \ + [$box do [list $slot eval {set :__initcmd}]] - # :analyze_initcmd -parsing_level 2 @class $name [$name eval {set :__initcmd}] } } - foreach methodName [$name info methods \ - -methodtype scripted \ - -callprotection all] { - # TODO: should the comment_blocks parser be relocated? - set blocks [:comment_blocks [${name} info method \ - body $methodName]] - foreach {line_offset block} $blocks { - if {$line_offset > 1} break; - set id [$entity @class-method $methodName] - CommentBlockParser process \ - -parsing_level 2 \ - -partof_entity $entity \ - -initial_section description \ - -entity $id \ - $block - } + foreach methodName [$box do [list $name info methods \ + -methodtype scripted \ + -callprotection all]] { + :readin \ + -partof_entity $entity \ + -docstring \ + -tag @class-method \ + -name $methodName \ + -parsing_level 2 \ + [$box do [list ${name} info method body $methodName]] } - :process=@object $entity class-object + :process=@object $project $entity class-object } - :public method process=@object {entity {scope ""}} { + # + # TODO: how to resolve to the current project's context. For now, + # we pass a parameter value, revisit this decision once we decide + # on a location for this behaviour. + # + :public class-object method process=@object {project entity {scope ""}} { set name [$entity name] - + set box [$project sandbox] # methods - foreach methodName [${name} {*}$scope info methods\ - -methodtype scripted \ - -callprotection all] { - - set blocks [:comment_blocks [${name} {*}$scope info method \ - body $methodName]] - foreach {line_offset block} $blocks { - if {$line_offset > 1} break; - set id [$entity @class-object-method $methodName] - CommentBlockParser :process \ - -parsing_level 2 \ - -partof_entity $name \ - -initial_section description \ - -entity $id \ - $block - } + + foreach methodName [$box do [list ${name} {*}$scope info methods\ + -methodtype scripted \ + -callprotection all]] { + set tag [join [list {*}$scope method] -] + # set id [$entity @$tag $methodName] + :readin \ + -partof_entity $entity \ + -docstring \ + -tag @$tag \ + -name $methodName \ + -parsing_level 2 \ + [$box do [list ${name} {*}$scope info method body $methodName]] } } - # activate the recoding of initcmds - ::nsf::configure keepinitcmd true - } } @@ -2429,19 +3104,23 @@ # 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]}} + # set :lineproc {{tag args} {puts stderr LINE=[list $tag {*}$args]; return [list $tag {*}$args]}} + set :lineproc {{tag args} {return [list $tag [expr {$args eq ""?$args:[list $args]}]]}} :method parse@tag {line} { lassign [apply [[current class] eval {set :lineproc}] {*}$line] tag line + #set line [lassign [apply [[current class] eval {set :lineproc}] {*}$line] tag] 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 } #:$tag [lrange $line 1 end] - :$tag $line + #:$tag {*}[expr {$line eq ""?$line:[list $line]}] + #:$tag $line + :$tag {*}$line } :method parse@text {line} { -# puts stderr "ADDLINE([current]) :@doc add $line end" + #puts stderr "ADDLINE([current]) :@doc add $line end" :@doc add $line end } :method parse@space {line} {;} @@ -2623,7 +3302,6 @@ next } :method parse@tag {line} { -# puts stderr "PART parse@tag [current]" set r [next] # puts stderr GOT=$r if {[::nsf::isobject $r] && [$r info has type ::nx::doc::Entity]} { @@ -2632,9 +3310,7 @@ return $r } :method parse@text {line} { -# puts stderr "PART parse@text [current]" if {[info exists :current_part]} { -# puts stderr "${:current_part} @doc add $line end" ${:current_part} @doc add $line end } else { :event=next $line Index: library/nx/nx.nxd =================================================================== diff -u -r5d5f67b7b4a9806e10419e44efdcfe724bfcff9b -r170cefa7618f2b44f91102711607fc6fa7d12c4f --- library/nx/nx.nxd (.../nx.nxd) (revision 5d5f67b7b4a9806e10419e44efdcfe724bfcff9b) +++ library/nx/nx.nxd (.../nx.nxd) (revision 170cefa7618f2b44f91102711607fc6fa7d12c4f) @@ -11,7 +11,7 @@ # essential language primitives (in particular, <<@command # ::nx::next>> and <<@command ::nx::current>>). # -# @require Tcl +# @require nsf # @version 1.0.0a # @namespace ::nx Index: library/nx/nx.tcl =================================================================== diff -u -r24f725ccfeb6bfaad96722a6f39bb517a07d4c5c -r170cefa7618f2b44f91102711607fc6fa7d12c4f --- library/nx/nx.tcl (.../nx.tcl) (revision 24f725ccfeb6bfaad96722a6f39bb517a07d4c5c) +++ library/nx/nx.tcl (.../nx.tcl) (revision 170cefa7618f2b44f91102711607fc6fa7d12c4f) @@ -8,6 +8,9 @@ # set ::nsf::bootstrap ::nx + + puts stderr ====[::nsf::configure objectsystem] + # # First create the ::nx object system. # @@ -21,7 +24,7 @@ -object.defaultmethod defaultmethod -object.destroy destroy -object.init init - -object.move move + -object.move move -object.objectparameter objectparameter -object.residualargs residualargs -object.unknown unknown @@ -54,6 +57,10 @@ foreach cmd [info command ::nsf::methods::class::*] { set cmdName [namespace tail $cmd] if {$cmdName in [list "filterguard" "mixinguard"]} continue + # set tgt [Class ::nsf::methods::class::info::methods -methodtype alias -callprotection all $cmdName] + #if {$tgt ne "" && [::nsf::methodproperty Class $cmdName redefine-protected]} { + # ::nsf::methodproperty Class $cmdName redefine-protected false + #} ::nsf::alias Class $cmdName $cmd unset cmdName } @@ -165,7 +172,7 @@ if {[info exists precondition]} {lappend conditions -precondition $precondition} if {[info exists postcondition]} {lappend conditions -postcondition $postcondition} array set "" [:__resolve_method_path -per-object $name] - #puts "object method $(object).$(methodName) [list $arguments] {...}" + # puts "object method $(object).$(methodName) [list $arguments] {...}" set r [::nsf::method $(object) -per-object $(methodName) $arguments $body {*}$conditions] if {$r ne ""} { # the method was not deleted @@ -228,7 +235,7 @@ :method public {args} { set p [lsearch -regexp $args {^(method|alias|attribute|forward|setter)$}] if {$p == -1} {error "$args is not a method defining method"} - set r [{*}:$args] + set r [::nsf::dispatch [::nsf::current object] {*}$args] if {$r ne ""} {::nsf::methodproperty [::nsf::self] $r call-protected false} return $r } @@ -1086,7 +1093,7 @@ ############################################ ::nsf::invalidateobjectparameter MetaSlot - MetaSlot create ::nx::Attribute -superclass ObjectParameterSlot + MetaSlot create ::nx::Attribute -superclass ::nx::ObjectParameterSlot createBootstrapAttributeSlots ::nx::Attribute { {value_check once} @@ -1280,7 +1287,7 @@ # (without syntactic overhead). ################################################################## - Class create ::nx::ScopedNew -superclass Class { + Class create ::nx::ScopedNew -superclass ::nx::Class { :attribute {withclass ::nx::Object} :attribute container Index: nsf.nxd =================================================================== diff -u --- nsf.nxd (revision 0) +++ nsf.nxd (revision 170cefa7618f2b44f91102711607fc6fa7d12c4f) @@ -0,0 +1,318 @@ +# -*- Tcl -*- + +# @package nsf +# +# ... +# +# @require Tcl +# @version 1.0.0a +# @namespace ::nsf + + +# @command assertion +# +# @parameter object:object +# @parameter assertionsubcmd:required +# @parameter arg + +# @command existsvar +# +# @parameter object:object +# @parameter var + +# @command methodproperty +# +# @parameter object:object +# @parameter -per-object:switch +# @parameter methodName +# @parameter methodproperty Accepts one of: '''protected''', +# '''redefine-protected''', '''returns''', '''slotobj''' +# @parameter value + +# @command setter +# +# @parameter object:object +# @parameter -per-object:switch +# @parameter parameter + +# @command createobjectsystem +# +# @parameter rootClass +# @parameter rootMetaClass +# @parameter systemMethods:optional + +# @command dispatch +# +# @parameter object:object +# @parameter -objscope +# @parameter command +# @parameter args + +# @command deprecated +# +# @parameter what +# @parameter oldCmd +# @parameter newCmd:optional + +# @command objectproperty +# +# @parameter object:object +# @parameter objectkind Accepts one of: '''type''', '''object''', +# '''class''', '''baseclass''', '''metaclass''', '''hasmixin''' +# @parameter value:optional + +# @command importvar +# +# @parameter object:object +# @parameter args + +# @command parametercheck +# +# @parameter -nocomplain +# @parameter param +# @parameter value:optional + +# @command forward +# +# @parameter object:object +# @parameter -per-object:switch +# @parameter method +# @parameter -default +# @parameter -earlybinding:switch +# @parameter -methodprefix +# @parameter -objscope:switch +# @parameter -onerror +# @parameter -verbose:switch +# @parameter target +# @parameter args + +# @command setvar +# +# @parameter object:object +# @parameter variable +# @parameter value + +# @command method +# +# @parameter object:object +# @parameter -inner-namespace +# @parameter -per-object +# @parameter -public +# @parameter name +# @parameter args +# @parameter body +# @parameter -percondition +# @parameter -postcondition + +# @command next +# +# Invokes the shadowed (i.e, same-named) method which is next along +# the precedence path and returns the results of this invocation. If +# '''next''' is called without arguments, the arguments of the current +# method (i.e., the arguments as present at the current callframe) are +# passed through to the shadowed method. If next is invoked with the +# flag --noArgs, the shadowed method is called without the active +# callframe arguments. If other arguments are specified for '''next''' +# explicitly, these will be passed instead. +# +# @parameter --noArgs:optional Deactivates the forward-passing of the current callframe's arguments +# @parameter args Explicitly declared arguments to pass to shadowed methods + + +# @command current +# +# An introspective command which allows you to explore the callstack +# from within the scope of a method (or a proc bound to an object via +# '''alias'''). If executed without specifying a subcommand, +# i.e. '''[current]''', it defaults to <<@command.command "current +# object">>. While '''current''' operates on the Tcl callstack, it is +# aware of object-specific callstack and frame information. To some +# extent, this object introspection protocol can be approximated at +# the script level by instrumenting '''[info frame]'''. +# +# If invoked outside of an object's scope (e.g., an ordinary proc, the +# global namespace), it fails and reports '''No current object'''. +# +# It comes with a variety of sub-commands to query the object-specific +# callstack information available. See below. +# +# @sub-command class Returns the name of the class holding the +# currently executing per-class method, if and only if called from +# within a per-class method. Note, that this method-owning class may +# be different to the class of the current object. If called from +# within a per-object method, it returns an empty string. +# +# @sub-command method Returns the name of the currently executing method. +# +# @sub-command callingclass Returns the name of the class which is +# calling into the executing method. +# +# @sub-command callingobject Returns the name of the object which is +# calling into the executing method. +# +# @sub-command calledclass Returns the name of the class that holds +# the originally (and now shadowed) target method (applicable in +# mixin classes and filters). +# +# @sub-command calledmethod Returns the name of the target method +# (applicable in a filter only). +# +# @sub-command isnextcall Returns 1 if the executing method was +# invoked via <<@command next>>, 0 otherwise. +# +# @sub-command next Returns the name of the method next on the +# precedence path as a string. +# +# @sub-command filterreg In a method serving as active filter, +# returns the name of the object (class) on which the method is +# registered as a filter. +# +# @command callinglevel Resolves the callstack level which represents +# the originating invocation into the currently executing method. Levels +# of indirection (e.g., filters) and method combination along the +# class linearisation path ('''next''') are ignored. The callstack is +# returned as an absolute level number (# followed by a digit). The +# level number returned can be directly used as the first argument to +# '''uplevel''' or '''upvar''' calls. See also <<@command.command +# "current activelevel">> +# +# @sub-command activelevel Returns the actual callstack level calling +# into the executing method. The active might correspond the +# '''callinglevel''', but this is not necessarily the case. The +# '''activelevel''' counts <<@command next>> call. The level +# is returned in a form so that it can be used as first argument in +# '''uplevel''' or '''upvar'''. + +# @command.command {current object} +# +# The default sub-command returns the name of the object currently +# active on the callstack. + + +# @command configure +# +# A top-level configuration facility which allows you modify +# properties of the "Next" object system for the scope of an entire +# '''interp'''. + +# @command.sub-command {configure filter} +# +# Allows turning on or off filters globally for the current +# interpreter. By default, the filter state is turned off. This +# function returns the old filter state. This filterless '''interp''' +# state is needed for the serializer which should introspect and stream the +# objects and classes without being affected by active filter. +# +# @parameter toggle Accepts either "on" or "off" +# @return The current filter activation state + +# @command.sub-command {configure softrecreate} +# +# Allows controlling the scheme applied when recreating an object or a +# class. By default, it is set to '''off'''. This means that the +# object/class is destroyed and all relations +# (e.g. subclass/superclass) to other objects/classes are revoked as +# well. If softrecreate is set to '''on''', the object is re-set, but not +# destroyed, the relations are +# kept. +# +# A "soft" recreation is important for e.g. reloading a file with +# class definitions (e.g. when used in OpenACS with file watching and +# reloading). With softrecreate set, it is not necessary to recreate +# dependent subclasses etc. Consider the example of a class hierarchy +# '''A <- B <- C'''. Without '''softrecreate''' set, a reload of +# '''B''' means first a destroy of B, leading to '''A <- C''', and +# instances of '''B''' are re-classed to <<@class +# ::nx::Object>>. When softrecreate is set, the class hierarchy +# remains untouched. +# +# @parameter toggle Accepts either "on" or "off" +# @return The current toggle value + + +# @command.sub-command {configure objectsystems} +# +# A mere introspection subcommand. It gives you the top level of the +# current object system, i.e., the ruling root class and root +# meta-class. For "Next": +# +# ''' +# configure objectsystems; # returns "::nx::Object ::nx::Class" +# ''' +# +# @return The active pair of root class and root meta-class + +# @command.sub-command {configure keepinitcmd} +# +# Usually, initcmd scripts are discarded by the '''interp''' once +# having been evaluated (in contrast to '''proc''' and '''method''' +# bodies). If you need them preserved for later introspection and +# processing (as in the "Next" documentation system), set this option +# to '''true'''. Then, the initcmd scripts are retained as a +# particular object variable ('''__initcmd''') of classes and +# objects. It defaults to '''false'''. +# +# @parameter value:boolean Either '''true''' or '''false''' +# @return The current setting + +# @command alias +# +# @parameter object:object The target object which becomes the owner of +# the aliased command (method, object or command). +# +# @parameter -per-object:switch If the target object is a class, one can +# specify the binding scope (i.e., per-object or per-class) of the +# aliased command +# +# @parameter methodName The name of the alias. +# @parameter -nonleaf:switch ... +# @parameter -objscope:switch ... +# @parameter cmdName The alias source as a command handle (as returned by ...) + +# @command finalize + +# @command interp +# +# @parameter name +# @parameter args + +# @command is +# +# @parameter value +# @parameter constraint +# @parameter -hasmixin +# @parameter -type +# @parameter arg + +# @command my +# +# @parameter -local +# @parameter method +# @parameter args + +# @command relation +# +# @parameter object +# @parameter relationtype +# @parameter value + +# @command provide_method +# +# @parameter require_name +# @parameter definition +# @parameter script:optional + +# @command require_method +# +# @parameter object +# @parameter name +# @parameter per_object + +# @command mixin +# +# @parameter object +# @parameter args + +# @command tmpdir +# +# @return The platform-specific path name to the system-wide temporary directory \ No newline at end of file Index: tests/doc.test =================================================================== diff -u -r8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 -r170cefa7618f2b44f91102711607fc6fa7d12c4f --- tests/doc.test (.../doc.test) (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) +++ tests/doc.test (.../doc.test) (revision 170cefa7618f2b44f91102711607fc6fa7d12c4f) @@ -50,7 +50,7 @@ } foreach {::line ::result} $lines { - ? {foreach {is_comment text} [doc analyze_line $::line] break; set is_comment} $::result "doc analyze_line '$::line'" + ? {foreach {is_comment text} [processor analyze_line $::line] break; set is_comment} $::result "processor analyze_line '$::line'" } set script { @@ -81,7 +81,7 @@ set blocks {1 {{ @package o} { 1 2 3}} 5 {{ @object o} { 1 2 3} {} { 345} { @tag1 part1} { @tag2 part2}} 17 {{ @object o # ####} { 1 2 3} {} { 345} { @tag1 part1} { @tag2 part2}}} - ? [list ::lcompare [doc comment_blocks $script] $blocks] 1 + ? [list ::lcompare [processor comment_blocks $script] $blocks] 1 } Test case parsing { @@ -344,12 +344,17 @@ ? [list [$entity @attribute] info has type ::nx::doc::@param] 1 ? [list [$entity @attribute] as_text] "Here! we check whether we can get a valid description block for text spanning multiple lines" +} + +Test case in-situ-basics { # # basic test for in-situ documentation (initcmd block) # # set script { - Class create Foo { + package req nx + namespace import -force ::nx::Class + Class create ::Foo { # The class Foo defines the behaviour for all Foo objects # # @author gustaf.neumann@wu-wien.ac.at @@ -364,7 +369,7 @@ :attribute attr1 :attribute attr2 :attribute attr3 - + # @.method foo # # This describes the foo method @@ -374,9 +379,9 @@ :method foo {a b} {;} } } - - eval $script - doc process ::Foo + + set prj [processor process -sandboxed -type eval $script] + set entity [@class id ::Foo] ? [list ::nsf::is object $entity] 1 ? [list $entity info has type ::nx::doc::@class] 1 @@ -388,7 +393,7 @@ ? [list ::nsf::is object $entity] 1 ? [list $entity info has type ::nx::doc::@attribute] 1 ? [list $entity @see] "::nx::Attribute ::nx::MetaSlot"; - + set entity [@method id ::Foo class foo] ? [list [@class id ::Foo] @method] $entity ? [list ::nsf::is object $entity] 1 @@ -401,128 +406,134 @@ } { ? [list expr [list [$p as_text] eq $expected]] 1; } + + $prj destroy +} - # TODO: how to realise scanning and parsing for mixed ex- and - # in-situ documentation? That is, how to differentiate between - # absolutely and relatively qualified comment blocks in line-based - # scanning phase (or later)? +# TODO: how to realise scanning and parsing for mixed ex- and +# in-situ documentation? That is, how to differentiate between +# absolutely and relatively qualified comment blocks in line-based +# scanning phase (or later)? +Test case mixed-mode-parsing { + set script { + package req nx namespace import -force ::nx::* # @class ::Bar # # The class Bar defines the behaviour for all Bar objects # # @author gustaf.neumann@wu-wien.ac.at # @author ssoberni@wu.ac.at - + # @class.attribute {::Bar attr1} # # This attribute 1 is wonderful # # @see ::nx::Attribute # @see ::nx::MetaSlot - + # @class.class-method {::Bar foo} # # # This describes the foo method # # @parameter a Provides a first value # @parameter b Provides a second value - + # @class.class-object-method {::Bar foo} # # This describes the per-object foo method # # @parameter a Provides a first value # @parameter b Provides a second value - + namespace eval ::ns1 { ::nx::Object create ooo } Class create Bar { - + :attribute attr1 :attribute attr2 :attribute attr3 - + # @.method foo # # This describes the foo method in the initcmd # # @parameter a Provides a first value # @parameter b Provides a second value - + :method foo {a b} { # This describes the foo method in the method body # # @parameter a Provides a first value (refined) - + } :class-object method foo {a b c} { # This describes the per-object foo method in the method body # # @parameter b Provides a second value (refined) - # @parameter c Provides a third value (first time) - + # @parameter c Provides a third value (first time) + } - + } } - - set i [doc process $script] - + + set prj [processor process -sandboxed -type eval $script] set entity [@class id ::Bar] - ? [list $i eval [list ::nsf::is object $entity]] 1 - ? [list $i eval [list $entity info has type ::nx::doc::@class]] 1 - ? [list $i eval [list $entity as_text]] "The class Bar defines the behaviour for all Bar objects"; - ? [list $i eval [list $entity @author]] "gustaf.neumann@wu-wien.ac.at ssoberni@wu.ac.at" - + ? [list ::nsf::is object $entity] 1 + ? [list $entity info has type ::nx::doc::@class] 1 + ? [list $entity as_text] "The class Bar defines the behaviour for all Bar objects"; + ? [list $entity @author] "gustaf.neumann@wu-wien.ac.at ssoberni@wu.ac.at" + # TODO: Fix the [@param id] programming scheme to allow (a) for # entities to be passed and the (b) documented structures set entity [@attribute id [@class id ::Bar] class attr1] - ? [list $i eval [list ::nsf::is object $entity]] 1 - ? [list $i eval [list $entity info has type ::nx::doc::@attribute]] 1 - ? [list $i eval [list $entity @see]] "::nx::Attribute ::nx::MetaSlot"; - + ? [list ::nsf::is object $entity] 1 + ? [list $entity info has type ::nx::doc::@attribute] 1 + ? [list $entity @see] "::nx::Attribute ::nx::MetaSlot"; + set entity [@method id ::Bar class foo] - ? [list $i eval [list [@class id ::Bar] @method]] $entity - ? [list $i eval [list ::nsf::is object $entity]] 1 - ? [list $i eval [list $entity info has type ::nx::doc::@method]] 1 - ? [list $i eval [list $entity as_text]] "This describes the foo method in the method body"; - - foreach p [$i eval [list $entity @parameter]] expected { + ? [list [@class id ::Bar] @method] $entity + ? [list ::nsf::is object $entity] 1 + ? [list $entity info has type ::nx::doc::@method] 1 + ? [list $entity as_text] "This describes the foo method in the method body"; + + foreach p [$entity @parameter] expected { "Provides a first value (refined)" "Provides a second value" } { - ? [list expr [list [$i eval [list $p as_text]] eq $expected]] 1; + ? [list expr [list [$p as_text] eq $expected]] 1; } - - + + set entity [@method id ::Bar class-object foo] - ? [list $i eval [list [@class id ::Bar] @class-object-method]] $entity - ? [list $i eval [list ::nsf::is object $entity]] 1 - ? [list $i eval [list $entity info has type ::nx::doc::@method]] 1 - ? [list $i eval [list $entity as_text]] "This describes the per-object foo method in the method body"; - - foreach p [$i eval [list $entity @parameter]] expected { + ? [list [@class id ::Bar] @class-object-method] $entity + ? [list ::nsf::is object $entity] 1 + ? [list $entity info has type ::nx::doc::@method] 1 + ? [list $entity as_text] "This describes the per-object foo method in the method body"; + + foreach p [$entity @parameter] expected { "Provides a first value" "Provides a second value (refined)" "Provides a third value (first time)" } { - ? [list expr [list [$i eval [list $p as_text]] eq $expected]] 1; + ? [list expr [list [$p as_text] eq $expected]] 1; } + + $prj destroy +} - - interp delete $i - - +Test case tag-notations-basics { + # # Some tests on structured/navigatable tag notations # - + # adding support for parsing levels # -- @class.object.object {::D o1 o2} @@ -539,15 +550,15 @@ ? [list ::nsf::isobject $entity] 1 ? [list $entity info has type ::nx::doc::@object] 1 ? [list $entity as_text] "We have a tag notation sensitive to the parsing level" - + set block { {@..object {o2 o3} We still look for balanced specs} } - + set entity [[@ @class ::D] @object o1] set cbp [CommentBlockParser process -parsing_level 2 -partof_entity $entity $block] ? [list $cbp status ? STYLEVIOLATION] 1 - + # This fails because we do not allow uninitialised/non-existing # entity objects (@object o) along the resolution path ... set block { @@ -556,15 +567,15 @@ set cbp [CommentBlockParser process $block] ? [list $cbp status ? INVALIDTAG] 1 -# ? [list $cbp message] "The tag 'object' is not supported for the entity type '@class'" - + # ? [list $cbp message] "The tag 'object' is not supported for the entity type '@class'" + set block { {@class.method.attribute attr1 We have an imbalanced specification (the names are underspecified!)} } set cbp [CommentBlockParser process $block] ? [list $cbp status ? STYLEVIOLATION] 1 ? [list $cbp message] "Imbalanced tag line spec: 'class method attribute' vs. 'attr1'" - + # For now, we do not verify and use a fixed scope of permissive tag # names. So, punctuation errors or typos are most probably reported # as imbalanced specs. In the mid-term run, this should rather @@ -575,14 +586,16 @@ set cbp [CommentBlockParser process $block] ? [list $cbp status ? STYLEVIOLATION] 1 ? [list $cbp message] "Imbalanced tag line spec: 'cla ss method parameter' vs. '::C foo p1'" - + set block { {@cla,ss.method.parameter {::C foo p1} We mistyped a tag fragment} } set cbp [CommentBlockParser process $block] ? [list $cbp status ? INVALIDTAG] 1 ? [list $cbp message] "The entity type '@cla,ss' is not available." +} +Test case tag-notations-extended { set script { # @class ::C # @@ -591,11 +604,11 @@ # @attribute attr1 Here we can only provide a description block for object parameters # @class.attribute {::C attr1} Here, we could also write '@class.class-attribute \{::C attr1\}', @attribute is a mere forwarder! In the context section, only one-liners are allowed! - + # @class.object.attribute {::C foo p1} A short description is ... # # .. is overruled by a long one ... - + # If addressing to a nested object, one strategy would be to use # @object and provide the object identifier (which reflects the # nesting, e.g. ::C::foo). However, we cannot distinguish between @@ -643,17 +656,17 @@ # @parameter p1 The most specific level! return [current method]-$p1-[current] }] - + # @.class-object-method.parameter {bar p1} # # This extended form allows to describe a method parameter with all # its structural features! set barHandle [:class-object method bar {p1} { return [current method]-$p1-[current] }] - + # @.object foo 'foo' needs to be defined before referencing any of its parts! - + # @.object.attribute {foo p1} # # The first element in the name list is resolved into a fully @@ -680,7 +693,7 @@ # @.class.class-object-attribute {Foo p2} Y Class create [current]::Foo { - + # @..attribute p1 # # @@ -710,7 +723,7 @@ # The desc of the ensemble object 'sub' # # @sub-method bar Only description available here ... - + # ISSUE: Should the helper object "sub" be documentable in its own # right? This would be feasible with the dotted notation from # within and outside the initcmd script block, e.g. "@object sub" or @@ -721,9 +734,9 @@ # way? Having an "@class-object-submethod" would not make much sense to # me?! :alias "sub bar" $barHandle - + # @.class-object-method sub A brief desc - + # @.class-object-method {"sub foo2"} # # could allow both (@sub-method is the attribute name, @method is a @@ -735,13 +748,14 @@ :class-object alias "sub foo2" $fooHandle } } - + # # 1) process the top-level comments (PARSING LEVEL 0) # - - doc analyze -noeval true $script - + + processor readin $script + + # --testing-- "@class ::C" set entity [@class id ::C] ? [list ::nsf::isobject $entity] 1 @@ -795,23 +809,30 @@ # 2) process the initcmd comments (PARSING LEVEL 1) # + ::nsf::configure keepinitcmd true eval $script - - doc analyze_initcmd @class ::C [::C eval {set :__initcmd}] - + ::nsf::configure keepinitcmd false + lassign [processor readin \ + -parsing_level 1 \ + -docstring \ + -tag @class \ + -name ::C \ + [::C eval {set :__initcmd}]] _ processed_entities + # a) existing, but modified ... - + set entity [@class id ::C] + ? $_ $entity ? [list ::nsf::isobject $entity] 1 ? [list $entity info has type ::nx::doc::@class] 1 ? [list $entity as_text] "This is the initcmd-level description of ::C which overwrites the global description (see above)" - + set entity [@attribute id $entity class attr1] ? [list ::nsf::isobject $entity] 1 ? [list $entity info has type ::nx::doc::@attribute] 1 ? [list $entity as_text] {This is equivalent to writing "@class-attribute attr1"} - - + + set entity [@object id ::C::foo] ? [list ::nsf::isobject $entity] 1 ? [list $entity info has type ::nx::doc::@object] 1 @@ -820,25 +841,25 @@ ? [list ::nsf::isobject $entity] 1 ? [list $entity info has type ::nx::doc::@attribute] 1 ? [list $entity as_text] "The first element in the name list is resolved into a fully qualified (absolute) entity, based on the object owning the initcmd!" - + # b) newly added ... - + # --testing-- @class-object-attribute attr2 set entity [@attribute id [@class id ::C] class-object attr2] ? [list ::nsf::isobject $entity] 1 ? [list $entity info has type ::nx::doc::@attribute] 1 ? [list $entity as_text] "Carries a short desc only"; - + # --testing-- @child-class Foo # TODO: provide a check against fully-qualified names in part specifications set entity [@class id ::C::Foo] ? [list ::nsf::isobject $entity] 1 ? [list $entity info has type ::nx::doc::@class] 1 ? [list $entity as_text] {By providing a fully-qualified identifier ("::Foo") you leave the context of the initcmd-owning object, i.e. you would NOT refer to a nested class object named "Foo" anymore!} - + set entity [@attribute id [@class id ::C] class p1] ? [list ::nsf::isobject $entity] 0; # should be 0 at this stage! - + # --testing -- @method foo set entity [@method id ::C class foo] ? [list ::nsf::isobject $entity] 1 @@ -858,19 +879,19 @@ set entity [@attribute id $cl class-object p2] ? [list ::nsf::isobject $entity] 1 ? [list $entity as_text] "Y" - + set entity [@method id ::C class sub] ? [list ::nsf::isobject $entity] 1 ? [list $entity as_text] "The desc of the ensemble object 'sub'" - + set entity [@method id ::C class sub::bar] ? [list ::nsf::isobject $entity] 1 ? [list $entity as_text] "Only description available here ..." - + set entity [@method id ::C class-object sub] ? [list ::nsf::isobject $entity] 1 ? [list $entity as_text] "A brief desc" - + set entity [@method id ::C class-object sub::foo2] ? [list ::nsf::isobject $entity] 1 ? [list $entity info has type ::nx::doc::@method] 1 @@ -881,37 +902,44 @@ set entity [@parameter id $entity "" p1] ? [list ::nsf::isobject $entity] 1 ? [list $entity as_text] "Some words on p1" - + # # 3a) process the attribute initcmds and method bodies (PARSING LEVEL 2)! # - - doc process=@class [@class id ::C] + set project [@project new -name "_%@"] + $project sandbox [Sandbox new] + processor process=@class $project [@class id ::C] + # methods ... - + set entity [@method id ::C class foo] ? [list ::nsf::isobject $entity] 1 ? [list $entity as_text] "Here goes some method-body-level description" set entity [@parameter id [@method id ::C class foo] "" p1] ? [list ::nsf::isobject $entity] 1 ? [list $entity as_text] "The most specific level!" - + # attributes ... - + # attr1 set entity [@attribute id [@class id ::C] class attr1] ? [list ::nsf::isobject $entity] 1 ? [list $entity info has type ::nx::doc::@attribute] 1 ? [list $entity as_text] {This description does not apply to the object parameter "attr1" owned by the ::C class, rather it is a description of the attribute slot object! How should we deal with this situation? Should this level overwrite the top-level and initcmd-level descriptions?} - + # # 3b) nested objects/ classes (PARSING LEVEL 2)! - # - - doc analyze_initcmd -parsing_level 2 @object ::C::foo [::C::foo eval {set :__initcmd}] - doc process=@object [@object id ::C::foo] - + # + processor readin \ + -docstring \ + -parsing_level 2 \ + -tag @object \ + -name ::C::foo \ + [::C::foo eval {set :__initcmd}] + + processor process=@object $project [@object id ::C::foo] + set entity [@object id ::C::foo] ? [list ::nsf::isobject $entity] 1 ? [list $entity info has type ::nx::doc::@object] 1 @@ -920,10 +948,15 @@ ? [list ::nsf::isobject $entity] 1 ? [list $entity info has type ::nx::doc::@attribute] 1 ? [list $entity as_text] {This is equivalent to stating "@class-object-attribute p1"} - - doc analyze_initcmd -parsing_level 2 @class ::C::Foo [::C::Foo eval {set :__initcmd}] - doc process=@class [@class id ::C::Foo] - + + processor readin \ + -docstring \ + -parsing_level 2 \ + -tag @class \ + -name ::C::Foo \ + [::C::Foo eval {set :__initcmd}] + processor process=@class $project [@class id ::C::Foo] + set cl [@class id ::C::Foo] ? [list ::nsf::isobject $cl] 1 set entity [@attribute id $cl class p1] @@ -932,108 +965,225 @@ set entity [@attribute id $cl class-object p2] ? [list ::nsf::isobject $entity] 1 ? [list $entity as_text] "" - - puts stderr ================================================= + # - # self documentation + # basic testing of "properties" (switch attributes) # - # if {[catch {set i [doc process nx::doc]} msg]} { - # puts stderr ERRORINFO=$::errorInfo - # if {[Exception behind? $msg]} { - # puts stderr [$msg info class]->[$msg message] - # } else { - # error $msg - # } - # } - # ? [list $i eval [list ::nsf::is object [@package id nx::doc]]] 1 - # puts stderr [$i eval [list [@package id nx::doc] text]] - # puts stderr [$i eval [list [@package id nx::doc] @require]] - # set path [file join /tmp nextdoc] - # if {[file exists $path]} { - # file delete -force $path - # } - # $i eval [list ::nx::doc::make doc \ - # -renderer ::nx::doc::TemplateData \ - # -outdir /tmp \ - # -project {name nextdoc url http://www.next-scripting.org/ version 0.1d}] - # interp delete $i - # - # core documentation - # - foreach path [list [file join [::nsf::tmpdir] NextScriptingFramework] \ - [file join [::nsf::tmpdir] NextScriptingLanguage]] { - if {[file exists $path]} { - file delete -force $path + ? [list $cl eval {set :@deprecated}] 0 + ? [list $cl eval {set :@stashed}] 0 + ? [list $cl eval {set :@c-implemented}] 0 + + ? [list $cl @deprecated] 1 + ? [list $cl @stashed] 1 + ? [list $cl @c-implemented] 1 + + ? [list $cl eval {set :@deprecated}] 1 + ? [list $cl eval {set :@stashed}] 1 + ? [list $cl eval {set :@c-implemented}] 1 + + set entity [@method id ::C class foo] + ? [list $entity eval {set :@syshook}] 0 + ? [list $entity @syshook] 1 + ? [list $entity eval {set :@syshook}] 1 + ? [list $entity @syshook 0] {wrong # args: should be "get obj prop"} + ? [list $entity eval {set :@syshook 0}] 0 + ? [list $entity @syshook] 1 + + +} + +Test case switch-parts { + + set script { + package req nx + namespace import ::nx::* + Class create Enil { + # The class Enil defines the behaviour for all Enil objects, + # however, it is deprecated and will be removed from the + # provided doc entities in the next iteration ... + # + # @author ssoberni@wu.ac.at + # @deprecated + + # @.attribute attr1 + # + # This attribute 1 will be invisibile in the generated doc + # + # @stashed + :attribute attr1 + + # @.method foo + # + # This describes the foo method which is called from within the + # nx-enabled Tcl engine + # + # @syshook + :method foo {a b} {;} + + :method baz {} { + # This method entity sets a couple of properties in series ... + # + # @property c-implemented syshook + } } } + + set prj [processor process -sandboxed -type eval $script] + set cl [@class id ::Enil] + + ? [list $cl eval {set :@deprecated}] 1 + ? [list $cl @deprecated] 1 + ? [list $cl eval {set :@c-implemented}] 0 + ? [list $cl eval {set :@stashed}] 0 + ? [list $cl @author] ssoberni@wu.ac.at + + set entity [@attribute id $cl class attr1] + ? [list $entity eval {set :@deprecated}] 0 + ? [list $entity eval {set :@stashed}] 1 + ? [list $entity @stashed] 1 + ? [list $entity eval {set :@c-implemented}] 0 + + set entity [@method id ::Enil class foo] + ? [list $entity eval {set :@deprecated}] 0 + ? [list $entity eval {set :@stashed}] 0 + ? [list $entity eval {set :@c-implemented}] 0 + ? [list $entity eval {set :@syshook}] 1 + ? [list $entity @syshook] 1 + + set entity [@method id ::Enil class baz] + ? [list $entity eval {set :@deprecated}] 0 + ? [list $entity eval {set :@stashed}] 0 + ? [list $entity eval {set :@c-implemented}] 1 + ? [list $entity @c-implemented] 1 + ? [list $entity eval {set :@syshook}] 1 + ? [list $entity @syshook] 1 + + +} - set i [interp create] - $i eval { - package req nx::doc - namespace import ::nx::* - namespace import ::nx::doc::* +puts stderr ================================================= +foreach path [list [file join [::nsf::tmpdir] NextScriptingFramework] \ + [file join [::nsf::tmpdir] NextScriptingLanguage]] { + if {[file exists $path]} { + file delete -force $path + } +} + +# TODO: Figure out where to place nsf.nxd for convenient location ... + +puts stderr >>>>>>>NextScriptingFramework<<<<<<<< +set project [::nx::doc::@project new \ + -name NextScriptingFramework \ + -url http://www.next-scripting.org/ \ + -version 1.0.0a \ + -@namespace "::nsf" \ + -sources { + package nsf + }] + +set project [processor process -sandboxed $project] + +::nx::doc::make doc \ + -renderer ::nx::doc::NxDocRenderer \ + -project $project \ + -outdir [::nsf::tmpdir] + + +puts stderr >>>>>>>NextScriptingLanguage<<<<<<<< + +set _ [time { + set project [::nx::doc::@project new \ + -name NextScriptingLanguage \ + -url http://www.next-scripting.org/ \ + -version 1.0.0a \ + -@namespace "::nx" \ + -sources { + package nx + }] + + # ISSUE: If calling '-namespace "::nx"' instead of '-@namespace + # "::nx"', we get an irritating failure. VERIFY! + processor process -sandboxed $project + ::nx::doc::make doc \ + -renderer ::nx::doc::NxDocRenderer \ + -project $project \ + -outdir [::nsf::tmpdir] +} 1] + +puts stderr ">>>>> gross timing for $project $_" +# exit + +# set i [interp create] +# $i eval { +# package req nx::doc +# namespace import ::nx::* +# namespace import ::nx::doc::* - # 1) NSF documentation project - set project [::nx::doc::@project new \ - -name NextScriptingFramework \ - -url http://www.next-scripting.org/ \ - -version 1.0.0a \ - -@namespace "::nsf"] +# # 1) NSF documentation project +# set project [::nx::doc::@project new \ +# -name NextScriptingFramework \ +# -url http://www.next-scripting.org/ \ +# -version 1.0.0a \ +# -@namespace "::nsf" \ +# -sources { +# {package nx} +# {scriptfile generic/nsf.tcl} +# {script {}} +# }] - doc process -noeval true generic/nsf.tcl +# # doc process -noeval true generic/nsf.tcl +# set project [doc process -sandboxed -type project $project] - ::nx::doc::make doc \ - -renderer ::nx::doc::NxDocRenderer \ - -project $project \ - -outdir [::nsf::tmpdir] +# ::nx::doc::make doc \ +# -renderer ::nx::doc::NxDocRenderer \ +# -project $project \ +# -outdir [::nsf::tmpdir] - #puts stderr NSF=[info commands ::nx::doc::entities::command::nsf::*] +# #puts stderr NSF=[info commands ::nx::doc::entities::command::nsf::*] - puts stderr TIMING=[time { - set project [::nx::doc::@project new \ - -name NextScriptingLanguage \ - -url http://www.next-scripting.org/ \ - -version 1.0.0a \ - -@namespace "::nx"] - # ISSUE: If calling '-namespace "::nx"' instead of '-@namespace - # "::nx"', we get an irritating failure. VERIFY! - doc process -noeval true library/nx/nx.tcl - ::nx::doc::make doc \ - -renderer ::nx::doc::NxDocRenderer \ - -project $project \ - -outdir [::nsf::tmpdir] - } 1] - } +# puts stderr TIMING=[time { +# set project [::nx::doc::@project new \ +# -name NextScriptingLanguage \ +# -url http://www.next-scripting.org/ \ +# -version 1.0.0a \ +# -@namespace "::nx"] +# # ISSUE: If calling '-namespace "::nx"' instead of '-@namespace +# # "::nx"', we get an irritating failure. VERIFY! +# doc process -noeval true library/nx/nx.tcl +# ::nx::doc::make doc \ +# -renderer ::nx::doc::NxDocRenderer \ +# -project $project \ +# -outdir [::nsf::tmpdir] +# } 1] +# } - interp delete $i +# interp delete $i - set _ { - # 2) XOTcl2 documentation project - doc process -noeval true library/xotcl/xotcl.tcl - ::nx::doc::make doc \ - -renderer ::nx::doc::NxDocTemplateData \ - -outdir [::nsf::tmpdir] \ - -project {name XOTcl2 url http://www.xotcl.org/ version 2.0.0a} +# set _ { +# # 2) XOTcl2 documentation project +# doc process -noeval true library/xotcl/xotcl.tcl +# ::nx::doc::make doc \ +# -renderer ::nx::doc::NxDocTemplateData \ +# -outdir [::nsf::tmpdir] \ +# -project {name XOTcl2 url http://www.xotcl.org/ version 2.0.0a} - # 3) NSL documentation project - doc process -noeval true library/nx/nx.tcl - ::nx::doc::make doc \ - -renderer ::nx::doc::NxDocTemplateData \ - -outdir [::nsf::tmpdir] \ - -project {name NextScriptingLanguage url http://www.next-scripting.org/ version 1.0.0a} +# # 3) NSL documentation project +# doc process -noeval true library/nx/nx.tcl +# ::nx::doc::make doc \ +# -renderer ::nx::doc::NxDocTemplateData \ +# -outdir [::nsf::tmpdir] \ +# -project {name NextScriptingLanguage url http://www.next-scripting.org/ version 1.0.0a} - # 4) Next Scripting Libraries - # doc process -noeval true ... - # ::nx::doc::make doc \ - # -renderer ::nx::doc::NxDocTemplateData \ - # -outdir [::nsf::tmpdir] \ - # -project {name NextScriptingLibraries url http://www.next-scripting.org/ version 1.0.0a} - } +# # 4) Next Scripting Libraries +# # doc process -noeval true ... +# # ::nx::doc::make doc \ +# # -renderer ::nx::doc::NxDocTemplateData \ +# # -outdir [::nsf::tmpdir] \ +# # -project {name NextScriptingLibraries url http://www.next-scripting.org/ version 1.0.0a} +# } -} - # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # @@ -1136,9 +1286,3 @@ # need namespace delimiters!) } - -# if {$log} { -# ::nx::doc::CommentState mixin delete ::nx::doc::CommentState::Log -# ::nx::doc::CommentLine mixin delete ::nx::doc::CommentLine::Log -# ::nx::doc::CommentSection mixin delete ::nx::doc::CommentSection::Log -# }

- ${:name}