# @package next::doc
#
# Study for documentation classes for Next.
#
# Compared to the "old" @ docmentation effort, this is a rather
# light-weight structure based on xotcl 2 (next) language
# features. The documentation classes build an (extensible) object
# structure which is used as a basis for some renderers. In general,
# the classes are defined in a way they can be used for
#
# a) building documentation outside the source code artefacts, or
#
# b) inside code artefacts (value added method definition commands
# providing extra arguments for the documentation). The
# documentation commands could reuse there names/arguments
# etc. directly from the method definition by issuing these
# commands inside the method definition methods.
#
# One could provide lint-like features to signal, whether the
# documentation is in sync with actually defined methods (when these
# are available).
#
# @require next
package provide next::doc 0.1
package require next
namespace eval ::nx::doc {
namespace import -force ::nx::*
# @command ::nx::doc::@
#
# The helper proc "@" is a conveniant way for creating new
# documentation objects with less syntactic overhead.
#
# @param class Request an instance of a particular entity class (e.g., ...)
# @param name What is the entity name (e.g., next::doc for a package)
# @param args A vector of arbitrary arguments, provided to the entity when being constructed
# @return The identifier of the newly created entity object
# @subcommand ::nx::doc::@#foo
#
# This is the first subcommand foo of "@"
# {{{
# set do 1;
# }}}
#
# @param -param1 do it
# @param param2 do it a second time
# @return Gives you a "foo" object
# @subcommand ::nx::doc::@#bar
#
# This is the second subcommand bar of "@"
#
# @param -param1 do it
# @param param2 do it a second time
# @return Gives you a "bar" object
proc @ {class name args} {$class new -name $name {*}$args}
# @command ::nx::doc::sorted
#
# This proc is used to sort instances by values of a specified
# attribute. {{{ set
# code 1; puts stderr $code; puts stderr [info script]; set l \{x\}
# }}} Und nun gehen wir in eine zweite Zeile ... und fügen einen Link ein (e.g., {{@object ::nx::doc::@object}})
#
# ... um nach einem Zeilenbruch weiterzumachen
# {{{
# \# Some comment
# set instances [list [Object new] [Object new]]
# ::nx::doc::sorted $instances; set l {{{x}}}; # Some comment
# {{{ }}}
# set instances [list [Object new] [Object new]]
# ::nx::doc::sorted $instances
# }}}
# Here it goes wider ...
# {{{
# set instances [list [Object new] [Object new]]
# ::nx::doc::sorted $instances
# }}}
#
# @param instances Points to a list of entity instances to sort e.g. {{@object ::nx::doc::@object}}
# @param sortedBy Indicates the attribte name whose values the sorting will be based on
# @return A list of sorted documentation entity instances {{{instances of @object}}}
proc sorted {instances sortedBy} {
set order [list]
foreach v $instances {lappend order [list $v [$v eval [list set :$sortedBy]]]}
set result [list]
foreach pair [lsort -index 1 $order] {lappend result [lindex $pair 0]}
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 {[::nx::core::is $error_msg object] && \
[::nx::core::is $error_msg type [self]]}]
}
# @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 [self]]
}
}
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
# entity class names, ...). Most importantly, it provides the
# basic name-generating mechanisms for documentation entities
# based on properties such as entity name, root namespace, etc.
#
# @param tag Defaults to the tag label to be used in comment tags. It may vary from the auto-generated default!
# @param root_namespace You may choose your own root-level namespace hosting the namespace hierarchy of entity objects
:attribute {tag {[string trimleft [string tolower [namespace tail [self]]] @]}}
:attribute {root_namespace "::nx::doc::entities"}
namespace eval ::nx::doc::entities {}
# @method id
#
# A basic generator for the characteristic ideas, based on the
# root_namespace, the tag label, and the fully qualified name of
# the documented entity
#
# @param name The name of the documented entity
# @return An identifier string, e.g., {{{ ::nx::doc::entities::object::ns1::Foo }}}
# @see tag
# @see root_namespace
:method id {name} {
set subns [string trimleft [namespace tail [self]] @]
return [:root_namespace]::${subns}::[string trimleft $name :]
}
:method new {-name:required args} {
# A refined frontend for object construction/resolution which
# provides for generating an explicit name, according to the
# rules specific to the entity type.
#
# @param name The of the documented entity
# @return The identifier of the newly generated or resolved entity object
:createOrConfigure [:id $name] -name $name {*}$args
}
:method createOrConfigure {id args} {
# 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 {[::nx::core::objectproperty $id object]} {
$id configure {*}$args
} else {
:create $id {*}$args
}
return $id
}
# @method get_unqualified_name
#
# @param qualified_name The fully qualified name (i.e., including the root namespace)
:method get_unqualified_name {qualified_name} {
return [string trim [string map [list [:root_namespace] ""] $qualified_name] ":"]
}
}
Class create PartClass -superclass EntityClass {
:method id {partof_object scope name} {
# ::Foo class foo
set subns [string trimleft [namespace tail [self]] @]
set partof_name [string trimleft $partof_object :]
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 [self]]'
require a partof entity to be set
}]] throw]}}
-name
args
} {
:createOrConfigure [:id [$partof name] [$part_attribute scope] $name] {*}[self args]
}
}
# @object ::nx::doc::PartAttribute
#
# This special-purpose Attribute variant realises (1) a cumulative
# value management and (2) support for distinguishing between
# literal parts (e.g., @author, @see) and object parts (e.g.,
# \@param).
#
# The cumulative value management adds the append() operation which
# translates into an add(...,end) operation. PartAttribute slots
# default to append() as their default setter operation. To draw a
# line between object and literal parts, PartAttribute slots either
# refer to a part_class (a subclass of Part) or they do not. If a
# part_class is given, the values will be transformed accordingly
# before being pushed into the internal storage.
::nx::MetaSlot create PartAttribute -superclass ::nx::Attribute {
# @param part_class
#
# The attribute slot refers to a concrete subclass of Part which
# describes the parts being managed by the attribute slot.
:attribute part_class:optional,class
:attribute scope
:method init args {
:defaultmethods [list get append]
:multivalued true
set :incremental true
# TODO: setting a default value leads to erratic behaviour;
# needs to be verified -> @author returns ""
# :default ""
if {![info exists :scope]} {
set :scope class
regexp -- {@(.*)-.*} [namespace tail [self]] _ :scope
}
next
}
:method require_part {domain prop value} {
if {[info exists :part_class]} {
if {[::nx::core::is $value object] && \
[::nx::core::is $value type ${:part_class}]} {
return $value
}
return [${:part_class} new \
-name [lindex $value 0] \
-partof $domain \
-part_attribute [self] \
-@doc [lrange $value 1 end]]
}
return $value
}
:method append {domain prop value} {
:add $domain $prop $value end
}
:method assign {domain prop value} {
set parts [list]
foreach v $value {
lappend parts [:require_part $domain $prop $v]
}
next $domain $prop $parts
}
:method add {domain prop value {pos 0}} {
set p [:require_part $domain $prop $value]
if {![$domain exists $prop] || $p ni [$domain $prop]} {
next $domain $prop $p $pos
}
return $p
}
:method delete {domain prop value} {
next $domain $prop [:require_part $prop $value]
}
}
Class create Entity {
#
# Entity is the base class for the documentation classes
#
# @param name
#
# gives you the name (i.e., the Nx object identifier) of the documented entity
:attribute name:required
# every Entity must be created with a "@doc" value and can have
# an optional initcmd
:method objectparameter args {next {@doc:optional __initcmd:initcmd,optional}}
:attribute @doc:multivalued {set :incremental 1}
:attribute @see -slotclass ::nx::doc::PartAttribute
# @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 {[::nx::core::objectproperty $docobj object]} break
}
if {[::nx::core::objectproperty $docobj object]} {
if {![$docobj 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"
}
}
}
# @method process
#
# This is an abstract hook method to be refined by the subclasses
# of Entity
#
# @param {-initial_section:optional "context"} Describes the section to parse first
# @return :integer Indicates the success of process the comment block
:method process {
{-initial_section:optional "context"}
-entity:optional
comment_block
} {
EntityClass process \
-partof_entity [self] \
-initial_section $initial_section \
{*}[expr {[info exists entity]?"-entity $entity":""}] \
$comment_block
}
# @method 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.
#
:method text {-as_list:switch} {
if {[info exists :@doc] && ${:@doc} ne ""} {
set doc ${:@doc}
set non_empty_elements [lsearch -all -not -exact $doc ""]
set doc [lrange $doc [lindex $non_empty_elements 0] [lindex $non_empty_elements end]]
if {$as_list} {
return $doc
} else {
return [subst [join $doc " "]]
}
}
}
:method filename {} {
return [[:info class] tag]_[string trimleft [string map {:: __} ${:name}] "_"]
}
}
EntityClass create @project -superclass Entity {
:attribute url
:attribute license
:attribute creationdate
}
#
# Now, define some kinds of documentation entities. The toplevel
# docEntities are named objects in the ::nx::doc::entities namespace
# to ease access to it.
#
# For now, we define here the following toplevel docEntities:
#
# - @package
# - @command
# - @object
# - ...
#
# These can contain multiple parts.
# - @method
# - @param
# - ...
#
EntityClass create @package -superclass Entity {
:attribute @require -slotclass ::nx::doc::PartAttribute
}
EntityClass create @command -superclass Entity {
:attribute @param -slotclass ::nx::doc::PartAttribute {
set :part_class @param
}
:attribute @return -slotclass ::nx::doc::PartAttribute {
:method require_part {domain prop value} {
set value [expr {![string match ":*" $value] ? "__out__: $value": "__out__$value"}]
next $domain $prop $value
#next $domain $prop "__out__ $value"
}
set :part_class @param
}
:attribute @subcommand -slotclass ::nx::doc::PartAttribute {
set :part_class @subcommand
}
}
EntityClass create @object \
-superclass Entity {
:attribute @superclass -slotclass ::nx::doc::PartAttribute
:attribute @author -slotclass ::nx::doc::PartAttribute
:attribute @method -slotclass ::nx::doc::PartAttribute {
set :part_class @method
:method require_part {domain prop value} {
# TODO: verify whether these scoping checks are sufficient
# 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] && \
![::nx::core::objectproperty [$domain name] ${:scope}]} {
error "The object '[$domain name]' does not qualify as '[$part_attribute scope]'"
}
next
}
}
:attribute @object-method -slotclass ::nx::doc::PartAttribute {
set :part_class @method
}
:attribute @param -slotclass ::nx::doc::PartAttribute {
set :part_class @param
}
:method inherited {member} {
if {[${:name} info is class]} {
set inherited [dict create]
foreach c [lreverse [${:name} info heritage]] {
set entity [[::nx::core::current class] id $c]
if {![::nx::core::is $entity object]} continue;
if {[$entity exists :${member}]} {
dict set inherited $entity [$entity $member]
}
}
return $inherited
}
}
:method process {
{-initial_section:optional "context"}
-entity:optional
comment_block
} {
next;
foreach methodName [${:name} info methods -methodtype scripted] {
set blocks [doc comment_blocks [${:name} info method \
body $methodName]]
foreach {line_offset block} $blocks {
if {$line_offset > 1} break;
set id [:@method $methodName]
$id process -initial_section description $block
}
}
foreach methodName [${:name} object info methods\
-methodtype scripted] {
set blocks [doc comment_blocks [${:name} object info method \
body $methodName]]
foreach {line_offset block} $blocks {
if {$line_offset > 1} break;
set id [:@object-method $methodName]
$id process -initial_section description $block
}
}
}
}
# @object ::nx::doc::Part
#
# A Part is a part of a documentation entity, defined by a
# separate object. Every Part is associated to another
# documentation entity and is identified by a name.
#
Class create Part -superclass Entity {
#:method objectparameter args {next {doc -use}}
:attribute partof:required
:attribute use
:attribute part_attribute
}
# @object ::nx::doc::@method
#
# "@method" is a named entity, which is part of some other
# docEntity (a class or an object). We might be able to use the
# "use" parameter for registered aliases to be able to refer to the
# documentation of the original method.
#
PartClass create @method \
-superclass Part {
:attribute {@modifier public} -slotclass ::nx::doc::PartAttribute
:attribute @param -slotclass ::nx::doc::PartAttribute {
set :part_class @param
}
:attribute @return -slotclass ::nx::doc::PartAttribute {
#
# TODO: @return spec fragments should be nameless,
# conceptually. They represent "out" parameters with each
# @method being allowed to have one only. For now, we fix
# this by injecting a dummy name "__out__" which should not
# be displayed. I shall fix this later and refactor it to a
# shared place between @method and @command.
#
:method require_part {domain prop value} {
set value [expr {![string match ":*" $value] ? "__out__: $value": "__out__$value"}]
next $domain $prop $value
}
set :part_class @param
}
:method parameters {} {
set params [list]
if {[info exists :@param]} {
foreach p [:@param] {
set value [$p name]
if {[$p exists default] || [$p name] eq "args" } {
set value "?[$p name]?"
}
lappend params $value
}
}
return $params
}
:method process {
{-initial_section:optional "context"}
comment_block
} {
next \
-initial_section $initial_section \
-entity [self] $comment_block
}
}; # @method
PartClass create @subcommand -superclass {Part @command}
# @object ::nx::doc::@param
#
# The entity type "@param" represents the documentation unit
# for several parameter types, e.g., object, method, and
# command parameters.
#
# @superclass ::nx::doc::entities::object::nx::doc::Part
# @superclass ::nx::doc::entities::object::nx::doc::Part
PartClass create @param \
-superclass Part {
:attribute spec
:attribute default
:object method id {partof name} {
# The method contains the parameter-specific name production rules.
#
# @param partof Refers to the entity object which contains this part
# @param name Stores the name of the documented parameter
# @modifier private
set partof_fragment [:get_unqualified_name ${partof}]
return [:root_namespace]::${:tag}::${partof_fragment}::${name}
}
# @object-method new
#
# The per-object method refinement indirects entity creation
# to feed the necessary ingredients to the name generator
#
# @param -part_attribute
# @param -partof
# @param -name
# @param args
:object method new {
-part_attribute
{-partof:substdefault {[[MissingPartofEntity new \
-message [subst {
Parts of type '[namespace tail [self]]'
require a partof entity to be set
}]] throw]}}
-name
args
} {
lassign $name name def
set spec ""
regexp {^(.*):(.*)$} $name _ name spec
:createOrConfigure [:id $partof $name] \
-spec $spec \
-name $name \
-partof $partof \
{*}[expr {$def ne "" ? "-default $def" : ""}] \
-part_attribute $part_attribute {*}$args
}
}
namespace export EntityClass @command @object @method @param \
@param @package @ Exception StyleViolation InvalidTag \
MissingPartofEntity ExceptionClass
}
namespace eval ::nx::doc {
Class create TemplateData {
# This mixin class realises a rudimentary templating language to
# be used in next::doc templates. It realises language expressions
# to verify the existence of variables and simple loop constructs
:method render {
{-initscript ""}
template
{entity:substdefault "[self]"}
} {
# Here, we assume the -nonleaf mode being active for {{{[eval]}}}.
set tmplscript [list subst [[::nx::core::current class] read_tmpl $template]]
$entity eval [subst -nocommands {
$initscript
$tmplscript
}]
# $entity eval [list subst $template]
}
#
# some instructions for a dwarfish, embedded templating language
#
:method let {var value} {
uplevel 1 [list ::set $var [expr {[info exists value]?$value:""}]]
return
}
:method for {var list body} {
set rendered ""
::foreach $var $list {
uplevel 1 [list ::set $var [set $var]]
append rendered [uplevel 1 [list subst $body]]
}
return $rendered
}
:method ?var {varname args} {
uplevel 1 [list :? -ops [list [::nx::core::current proc] -] \
"\[info exists $varname\]" {*}$args]
}
:method ? {
{-ops {? -}}
expr
then
next:optional
args
} {
if {[info exists next] && $next ni $ops} {
return -code error "Invalid control operator '$next', we expect one of $ops"
}
set condition [list expr $expr]
if {[uplevel 1 $condition]} {
return [uplevel 1 [list subst $then]]
} elseif {[info exists next]} {
if {$next eq "-"} {
set args [lassign $args next_then]
if {$next_then eq ""} {
return -code error "A then script is missing for '-'"
}
if {$args ne ""} {
return -code error "Too many arguments: $args"
}
return [uplevel 1 [list subst $next_then]]
}
return [:$next {*}$args]
}
}
:method include {template} {
uplevel 1 [list subst [[::nx::core::current class] read_tmpl $template]]
}
#
# TODO: This should make turn into a hook, the output
# specificities should move in a refinement of TemplateData, e.g.,
# DefaultHtmlTemplateData or the like.
#
:method fit {str max {placeholder "..."}} {
if {[llength [split $str ""]] < $max} {
return $str;
}
set redux [llength [split $placeholder ""]]
set margin [expr {($max-$redux)/2}]
return "[string range $str 0 [expr {$margin-1}]]$placeholder[string range $str end-[expr {$margin+1}] end]"
}
:method list_structural_features {} {
set entry {{"access": "$access", "host": "$host", "name": "$name", "url": "$url", "type": "$type"}}
set entries [list]
if {[:info is type ::nx::doc::@package]} {
set features [list @object @command]
foreach feature $features {
set instances [sorted [$feature info instances] name]
foreach inst $instances {
set access ""
set host [:name]
set name [$inst name]
set url "[$inst filename].html"
set type [$feature tag]
lappend entries [subst $entry]
}
}
} elseif {[:info is type ::nx::doc::@object]} {
# TODO: fix support for @object-method!
set features [list @method @param]
foreach feature $features {
if {[:exists $feature]} {
set instances [sorted [:$feature] name]
foreach inst $instances {
set access [expr {[:exists @modifier]?[:@modifier]:""}]
set host [:name]
set name [$inst name]
set url "[:filename].html#[$feature tag]_[$inst name]"
set type [$feature tag]
lappend entries [subst $entry]
}
}
}
}
return "\[[join $entries ,\n]\]"
}
:method code {{-inline true} script} {
return [expr {$inline?"$script
":"
$script"}] } :method link {entity_type args} { set id [$entity_type id {*}$args] if {![::nx::core::is $id object]} return; set pof "" if {[$id info is type ::nx::core::Part]} { set pof "[[$id partof] name]#" } return "$pof[$id name]" } :method text {} { # Provide \n replacements for empty lines according to the # rendering frontend (e.g., in HTML ->