Index: library/lib/doc-tools.tcl
===================================================================
diff -u -r18122dd21b99cf0d5b4cd01635048641a23aa051 -re29308a6c15da697df375716a3ae3787ade64218
--- library/lib/doc-tools.tcl (.../doc-tools.tcl) (revision 18122dd21b99cf0d5b4cd01635048641a23aa051)
+++ library/lib/doc-tools.tcl (.../doc-tools.tcl) (revision e29308a6c15da697df375716a3ae3787ade64218)
@@ -94,84 +94,6 @@
return $result
}
- # @method ::nx::doc::ExceptionClass#behind?
- #
- # This helper method can be used to decide whether a message
- # caught in error propagation qualifies as a valid exception
- # object.
- #
- # @param error_msg Stands for the intercepted string which assumingly represents an exception object identifier
- # @return 0 or 1
- Class create ExceptionClass -superclass Class {
- # A meta-class which defines common behaviour for exceptions
- # types, used to indicate particular events when processing
- # comment blocks.
-
- :method behind? {error_msg} {
- return [expr {[::nsf::is $error_msg object] && \
- [::nsf::is $error_msg type [current]]}]
- }
-
- # @method thrown_by?
- #
- # This helper method realises a special-purpose catch variant to
- # safely evaluate scripts which are expected to produce exception
- # objects
- #
- # @return 1 iff an exception object is caught, 0 if the script did
- # not blow or it returned an error message not pointing to an
- # exception object
- :method thrown_by? {script} {
- if {[uplevel 1 [list ::catch $script msg]]} {
- return [:behind? [uplevel 1 [list set msg]]]
- }
- return 0
- }
-
- }
-
- ExceptionClass create Exception {
- # The base class for exception objects
- #
- # @param message An explanatory message meant for the developer
- :attribute message:required
- # @param stack_trace Contains the stack trace as saved at the time of throwing the exception object
- :attribute stack_trace
-
- # @method throw
- #
- # The method makes sure that an Exception object is propagated
- # through the Tcl ::error mechanism, starting from the call site's
- # scope
- :method throw {} {
- if {![info exists :stack_trace] && [info exists ::errorInfo]} {
- :stack_trace $::errorInfo
- }
- #
- # uplevel: throw at the call site
- #
- uplevel 1 [list ::error [current]]
- }
- }
-
- ExceptionClass create StyleViolation -superclass Exception {
- # This exception indicates from within the parsing machinery that
- # a comment block was malformed (according to the rules layed out
- # by the statechart-like parsing specification.
- }
- ExceptionClass create InvalidTag -superclass Exception {
- # This exception is thrown upon situations that invalid tags are
- # used at various levels of entity/part nesting. This usually
- # hints at typos in tag labels or the misuse of tags in certain
- # contexts.
- }
- ExceptionClass create MissingPartofEntity -superclass Exception {
- # This exception occurs when parts are defined without providing
- # an owning (i.e., partof) entity. This might be caused by
- # failures in resolving this context.
- }
-
-
Class create EntityClass -superclass Class {
# A meta-class for named documenation entities. It sets some
# shared properties (e.g., generation rules for tag names based on
@@ -211,7 +133,7 @@
:method id {name} {
set subns [string trimleft [namespace tail [current]] @]
#return [:root_namespace]::${subns}::[string trimleft $name :]
- puts stderr "[current callingproc] -> [:root_namespace]::${subns}[:get_fully_qualified_name $name]"
+ # puts stderr "[current callingproc] -> [:root_namespace]::${subns}[:get_fully_qualified_name $name]"
return "[:root_namespace]::${subns}[:get_fully_qualified_name $name]"
}
@@ -227,7 +149,7 @@
}
:method createOrConfigure {id args} {
- puts stderr "createOrConfigure id $id"
+ # 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
@@ -263,17 +185,13 @@
# puts stderr "ID -> [join [list [:root_namespace] $subns $partof_name $scope $name] ::]"
return [join [list [:root_namespace] $subns $partof_name $scope $name] ::]
}
+
:method new {
-part_attribute
- {-partof:substdefault {[[MissingPartofEntity new \
- -message [subst {
- Parts of type '[namespace tail [current]]'
- require a partof entity to be set
- }]] throw]}}
+ -partof:required
-name
args
} {
- puts stderr "+++ PART [current args]"
:createOrConfigure [:id [:get_fully_qualified_name [$partof name]] [$part_attribute scope] $name] {*}[current args]
}
}
@@ -321,7 +239,7 @@
:method require_part {domain prop value} {
if {[info exists :part_class]} {
if {[::nsf::is $value object] && \
- [::nsf::is $value type ${:part_class}]} {
+ [$value info has type ${:part_class}]} {
return $value
}
return [${:part_class} new \
@@ -384,7 +302,7 @@
# puts stderr SLOTS=$slots
foreach s $slots {
# [$s info is type ::nx::doc::PartAttribute]
- if {![::nsf::objectproperty $s type ::nx::doc::PartAttribute] || ![$s eval {info exists :part_class}]} continue;
+ 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]} {
@@ -475,7 +393,6 @@
if {[[current class] eval {info exists :container}]} {
set container [[current class] container]
next
- puts stderr "--- entity [current] starts living, register with $container"
$container register [current]
} else {
next
@@ -509,18 +426,15 @@
:method init {} {
next
- puts stderr "APPLYING Resolvable container [current]"
EntityClass mixin add [current class]::Resolvable
[current class]::Resolvable container [current]
- puts stderr "APPLYING Containable container [current]"
# Entity mixin add [current class]::Containable
[current class]::Containable container [current]
}
:method register {containable:object,type=::nx::doc::Entity} {
set tag [[$containable info class] tag]
if {[:info callable methods -application "@$tag"] ne ""} {
- puts stderr "REGISTERING: tag $tag containable $containable on [current]"
:@$tag $containable
}
}
@@ -639,7 +553,7 @@
# partof object, which is the object behind [$domain name]?
if {[info exists :scope] &&
![::nsf::objectproperty [$domain name] ${:scope}]} {
- error "The object '[$domain name]' does not qualify as '[$part_attribute scope]'"
+ error "The entity '[$domain name]' does not qualify as '${:scope}'"
}
next
}
@@ -767,7 +681,6 @@
} else {
set comment "cannot check object, probably not instantiated"
}
- #puts stderr "XXXX [current] ${:name} is part of ${:partof} // [${:partof} name]"
return [concat $params
$comment]
}
return $params
@@ -819,11 +732,7 @@
# @param args
:object method new {
-part_attribute
- {-partof:substdefault {[[MissingPartofEntity new \
- -message [subst {
- Parts of type '[namespace tail [current]]'
- require a partof entity to be set
- }]] throw]}}
+ -partof:required
-name
args
} {
@@ -842,8 +751,7 @@
}
namespace export CommentBlockParser @command @object @class @package @project @method \
- @param @ Exception StyleViolation InvalidTag \
- MissingPartofEntity ExceptionClass
+ @param @
}
@@ -1028,7 +936,7 @@
:method list_structural_features {} {
set entry {{"access": "$access", "host": "$host", "name": "$name", "url": "$url", "type": "$type"}}
set entries [list]
- if {[:info is type ::nx::doc::@package]} {
+ if {[:info has type ::nx::doc::@package]} {
set features [list @object @command]
foreach feature $features {
set instances [sorted [$feature info instances] name]
@@ -1041,7 +949,7 @@
lappend entries [subst $entry]
}
}
- } elseif {[:info is type ::nx::doc::@object]} {
+ } elseif {[:info has type ::nx::doc::@object]} {
# TODO: fix support for @object-method!
set features [list @method @param]
foreach feature $features {
@@ -1057,7 +965,7 @@
}
}
}
- } elseif {[:info is type ::nx::doc::@command]} {
+ } elseif {[:info has type ::nx::doc::@command]} {
set features @subcommand
foreach feature $features {
if {[info exists :$feature]} {
@@ -1090,7 +998,7 @@
set id [$entity_type id {*}$args]
if {![::nsf::is $id object]} return;
set pof ""
- if {[$id info is type ::nx::doc::Part]} {
+ if {[$id info has type ::nx::doc::Part]} {
set pof "[[$id partof] name]#"
set filename [[$id partof] filename]
} else {
@@ -1100,7 +1008,10 @@
}
:method as_text {} {
- return [string map {"\n\n" "
"} [next]]
+ set pre [next]
+ set post [string map {"\n\n" "
"} $pre]
+ return $post
+ #return [string map {"\n\n" "
"} [next]]
}
}
@@ -1314,14 +1225,17 @@
# (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
- if {[catch {::nx::doc::CommentBlockParser process $block} msg]} {
- if {![InvalidTag behind? $msg] && ![StyleViolation behind? $msg] && ![MissingPartofEntity behind? $msg]} {
- if {[Exception behind? $msg]} {
- error [$msg info class]->[$msg message]
- }
- error $msg
- }
- }
+ 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
+ # }
+ # }
}
# 3) process the recorded object additions, i.e., the stored
# initcmds and method bodies.
@@ -1429,9 +1343,11 @@
# TODO: Passing $id as partof_entity appears unnecessary,
# clean up the logic in CommentBlockParser->process()!!!
#puts stderr "==== CommentBlockParser process -partof_entity $id {*}$arguments"
- if {[catch {CommentBlockParser process -partof_entity $id {*}$arguments} msg]} {
- lappend failed_blocks $line_offset
- }
+ set cbp [CommentBlockParser process -partof_entity $id {*}$arguments]
+
+# if {[catch {CommentBlockParser process -partof_entity $id {*}$arguments} msg]} {
+# lappend failed_blocks $line_offset
+# }
}
}; # analyze_initcmd method
@@ -1579,7 +1495,7 @@
set values [join [dict values $top_level_entities]]
puts stderr "VALUES=$values"
foreach e $values {
- puts stderr "PROCESSING=$e render -initscript $init $tmpl"
+ #puts stderr "PROCESSING=$e render -initscript $init $tmpl"
set content [$e render -initscript $init $tmpl]
:write $content [file join $project_path "[$e filename].$ext"]
puts stderr "$e written to [file join $project_path [$e filename].$ext]"
@@ -1601,38 +1517,64 @@
# events which are then signalled to the parsed entity.
#
Class create CommentBlockParser {
+ :attribute {message ""}
+ :attribute {status:in "COMPLETED"} {
+ set :incremental 1
+
+ set :statuscodes {
+ COMPLETED
+ INVALIDTAG
+ MISSINGPARTOF
+ STYLEVIOLATION
+ }
+
+ :method type=in {name value} {
+ if {$value ni ${:statuscodes}} {
+ error "Invalid statuscode '$code'."
+ }
+ return $value
+ }
+
+ :method ? [list obj var value:in,slot=[current object]] {
+ return [expr {[:get $obj $var] eq $value}]
+ }
+ :method is {obj var value} {
+ return [expr {$value in ${:statuscodes}}]
+ }
+ }
+
:attribute processed_section {
set :incremental 1
:method assign {domain prop value} {
set current_entity [$domain current_entity]
set scope [expr {[$current_entity info is class]?"object mixin":"mixin"}]
puts stderr "Switching: [$current_entity {*}$scope] --> target $value"
- if {[$domain eval [list info exists :$prop]] && [:get $domain $prop] in [$current_entity {*}$scope]} {
- $current_entity {*}$scope delete [:get $domain $prop]
+ if {[$domain eval [list info exists :$prop]] && [:get $domain $prop] in [$current_entity {*}$scope]} {
+ $current_entity {*}$scope delete [:get $domain $prop]
+ }
+ $current_entity {*}$scope add [next $domain $prop $value]
}
- $current_entity {*}$scope add [next $domain $prop $value]
}
- }
- :attribute current_entity:object
-
- :object method process {
- {-partof_entity ""}
- {-initial_section context}
- -entity
- block
- } {
+ :attribute current_entity:object
- if {![info exists entity]} {
+ :object method process {
+ {-partof_entity ""}
+ {-initial_section context}
+ -entity
+ block
+ } {
+
+ if {![info exists entity]} {
set entity [Entity]
}
- set parser_obj [:new -current_entity $entity -volatile]
+ set parser_obj [:new -current_entity $entity]
$parser_obj [current proc] \
-partof_entity $partof_entity \
-initial_section $initial_section \
$block
- return [$parser_obj current_entity]
+ return $parser_obj
}
:forward has_next expr {${:idx} < [llength ${:comment_block}]}
@@ -1642,10 +1584,15 @@
return $r
}
:forward rewind incr :idx -1
-# :forward fastforward set :idx {% expr {[llength ${:comment_block}] - 1} }
+# :forward fastforward set :idx {% expr {[llength ${:comment_block}] - 1} }
:forward fastforward set :idx {% llength ${:comment_block}}
-
+ :method cancel {statuscode {msg ""}} {
+ :fastforward
+ :status $statuscode
+ :message $msg
+ uplevel 1 [list ::return -code error $statuscode]
+ }
#
# everything below assumes that the current class is an active mixin
# on an instance of an Entity subclass!
@@ -1671,7 +1618,7 @@
${:current_entity} eval [list set :partof_entity $partof_entity]
set is_first_iteration 1
- set failure ""
+# set failure ""
#
# Note: Within the while-loop, two object variables constantly
@@ -1688,11 +1635,12 @@
}
if {[catch {
- puts stderr "PROCESS ${:current_entity} event=process $line"
+ # puts stderr "PROCESS ${:current_entity} event=process $line"
${:current_entity} event=process $line
} failure]} {
- puts stderr ERRORINFO=$::errorInfo
- :fastforward
+ if {![:status is $failure]} {
+ ::return -code error -errorinfo $::errorInfo
+ }
}
}
if {!$is_first_iteration} {
@@ -1704,9 +1652,10 @@
${:current_entity} {*}$scope mixin delete ${:processed_section}
}
- if {$failure ne ""} {
- error $failure
- }
+ # if {$failure ne ""} {
+ # # puts stderr ERRORINFO=$::errorInfo
+ # return -code error -errorinfo $::errorInfo $failure
+ # }
}; # CommentBlockParser->process()
@@ -1756,9 +1705,9 @@
} else {
append msg "A ${src_line_type} line is followed by a ${tgt_line_type} line"
}
- [StyleViolation new -message $msg] throw
+ ${:block_parser} cancel STYLEVIOLATION $msg
+ # [StyleViolation new -message $msg] throw
}
-
return [list $tgt_line_type $transitions(${src_line_type}->${tgt_line_type})]
}
@@ -1792,10 +1741,11 @@
set line [split [string trimleft $line]]
set tag [lindex $line 0]
if {[:info callable methods -application $tag] eq ""} {
- [InvalidTag new -message [subst {
- The tag '$tag' is not supported for the entity type
- '[namespace tail [:info class]]'
- }]] throw
+ # [InvalidTag new -message [subst {
+ # The tag '$tag' is not supported for the entity type
+ # '[namespace tail [:info class]]'
+ # }]] throw
+ ${:block_parser} cancel INVALIDTAG "The tag '$tag' is not supported for the entity type '[namespace tail [:info class]]"
}
puts stderr ":$tag [lrange $line 1 end]"
:$tag [lrange $line 1 end]
@@ -1865,12 +1815,14 @@
lassign [:resolve_partof_entity $tag $name] nq_name partof_entity
if {$partof_entity ne ""} {
if {[$partof_entity info callable methods -application $tag] eq ""} {
- [InvalidTag new -message [subst {
- The tag '$tag' is not supported for the entity type
- '[namespace tail [$partof_entity info class]]'
- }]] throw
+ ${:block_parser} cancel INVALIDTAG "The tag '$tag' is not supported for the entity type
+ '[namespace tail [$partof_entity info class]]'"
+ # [InvalidTag new -message [subst {
+ # The tag '$tag' is not supported for the entity type
+ # '[namespace tail [$partof_entity info class]]'
+ # }]] throw
}
- puts stderr "1. $partof_entity $tag $nq_name {*}$args"
+ # puts stderr "1. $partof_entity $tag $nq_name {*}$args"
set current_entity [$partof_entity $tag $nq_name {*}$args]
} else {
@@ -1884,11 +1836,12 @@
# InvalidTag exceptions in analyze()
#
set qualified_tag [namespace qualifiers [current]]::$tag
- if {[EntityClass info instances -closure $qualified_tag] eq ""} {
- [InvalidTag new -message [subst {
- The entity type '$tag' is not available
- }]] throw
- }
+ ${:block_parser} cancel INVALIDTAG "The entity type '$tag' is not available"
+ # if {[EntityClass info instances -closure $qualified_tag] eq ""} {
+ # [InvalidTag new -message [subst {
+ # The entity type '$tag' is not available
+ # }]] throw
+ # }
set current_entity [$tag new -name $nq_name {*}$args]
}
#
@@ -1901,6 +1854,48 @@
$current_entity current_comment_line_type ${:current_comment_line_type}
$current_entity block_parser ${:block_parser}
}
+
+ :method parse@tag {line} {
+ lassign $line axes names args
+
+ set operand ${:partof_entity}
+ set axes [split [string trimleft $axes @] .]
+ if {[llength $axes] != [llength $names]} {
+ ${:block_parser} cancel STYLEVIOLATION "Invalid tag line specification in '$line'."
+ # [StyleViolation new -message [subst {
+ # Invalid tag line specification in '$line'.
+ # }]] throw
+ }
+ foreach axis $axes value $names {
+ puts stderr "axis $axis value $value"
+ if {$operand eq ""} {
+ if {[EntityClass info instances @$axis] eq ""} {
+ ${:block_parser} cancel INVALIDTAG "The entity type '@$axis' is not available."
+ # [InvalidTag new -message [subst {
+ # The entity type '@$axis' is not available
+ # }]] throw
+ }
+ puts stderr "FIRST LEVEL: @$axis new -name $value"
+ set operand [@$axis new -name $value]
+ } else {
+ if {[$operand info callable methods -application @$axis] eq ""} {
+ ${:block_parser} cancel INVALIDTAG "The tag '$axis' is not supported for the entity type '[namespace tail [$operand info class]]'"
+ # [InvalidTag new -message [subst {
+ # The tag '$axis' is not supported for the entity type
+ # '[namespace tail [$operand info class]]'
+ # }]] throw
+ }
+ set operand [$operand @$axis $value]
+ }
+ }
+ $operand @doc $args
+
+ ${:block_parser} current_entity $operand
+ ${:block_parser} processed_section [current class]
+ $operand current_comment_line_type ${:current_comment_line_type}
+ $operand block_parser ${:block_parser}
+ }
+
# :method parse@text {line} { next }
# :method parse@space {line} { next }
@@ -1913,7 +1908,7 @@
->text parse
->tag next
text->text parse
- text->space ""
+ text->space parse
space->text parse
space->space parse
space->tag next
@@ -1954,11 +1949,19 @@
}
:method parse@tag {line} {
puts stderr "PART parse@tag [current]"
- set :current_part [next]
+ set r [next]
+ if {[::nsf::objectproperty $r object] && [$r info has type ::nx::doc::Entity]} {
+ set :current_part $r
+ }
+ return $r
}
:method parse@text {line} {
puts stderr "PART parse@text [current]"
- ${:current_part} @doc add $line end
+ if {[info exists :current_part]} {
+ ${:current_part} @doc add $line end
+ } else {
+ :event=next $line
+ }
}
# :method parse@space {line} {;}
}