package provide next::doc 0.1
package require next
#
# Study for documentation classes for Next.
#
# Compared to the "old" @ docmentation effort, this is a rather
# light-weight structure based on xotcl 2 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 issueing 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).
#
namespace eval ::next::doc {
namespace import -force ::next::*
#
# A few helper commands:
# - "@" is a conveniant way for creating new objects with less syntactic overhead
# - "sorted" is used to sort instances by values of a specified attribute
#
proc @ {class name args} {$class new -name $name {*}$args}
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
}
Class create EntityFactory -superclass Class {
#
# EntityFactory is a meta-class for named doc entities
#
:attribute tag:required
namespace eval ::next::doc::entities {}
set :root_namespace ::next::doc::entities
:method init {} {
next
[:info class] eval set :tags([:tag]) [self]
}
:method createOrConfigure {id arguments} {
namespace eval $id {}
if {[::next::core::objectproperty $id object]} {
$id configure {*}$arguments
} else {
:create $id {*}$arguments
}
}
}
Class create Entity {
#
# Entity is the base class for the documentation classes
#
# every Entity must be created with a "doc" value and can have
# an optional initcmd
:method objectparameter args {next {doc __initcmd:initcmd,optional}}
:attribute doc
#the following two cases (incremental multivalued) could be nicer
:attribute {variants:multivalued ""} {set :incremental 1}
:attribute {params:multivalued ""} {set :incremental 1}
# @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 {NextCommand NextClass} {
set docobj [$thing id $use]
if {[::next::core::objectproperty $docobj object]} break
}
if {[::next::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
:method process {comment_block} {
error "Implement '[::next::core::current method]()' for the class '[:info class]'"
}
# @method param
#
# The method param is currently used for documenting parameters of
# tcl-commands and xotcl methods. Most probably, it should cover
# object parameters as well. The parameters are identified by a
# name and ar part of another documentation entitiy
#
:method param {param doc {-use ""}} {
set flags [list -param $param]
if {[llength $param]>1} {
lappend flags -default [lindex $param 1]
set param [lindex $param 0]
}
set name $param
if {[regexp {^(.*):(.*)$} $param _ name spec]} {
lappend flags -spec $spec
}
lappend flags -fullname param
@ NextCommand::Parameter $name -partof [self] {*}$flags [:_doc $doc $use params $name]
}
# @method variant
#
# variants are used in cases, where depending on a parameter, the
# semantics of a command (and therefore its documentation) is
# completely different. A typical case are subcommands in Tcl.
#
:method variant {name doc {-use ""}} {
@ NextCommand::Variant $name -partof [self] [:_doc $doc $use variants $name]
}
# @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 {} {subst ${:doc}}
}
#
# Now, define some kinds of docEntities. The toplevel docEntities
# are named objects in the ::next::doc::entities namespace to ease access to it.
#
# We define here the following toplevel docEntities (e.g. xotclObject will follow):
# - NextCommand
# - NextObject
#
# The xotcl methods are defined as Parts.
# - NextMethod
#
EntityFactory create NextCommand \
-tag "command" \
-superclass Entity {
:attribute name
:attribute arguments
:attribute {returns ""}
:object method id {name} {return [[:info class] eval {set :root_namespace}]::cmd::[string trimleft $name :]}
:object method new args {
foreach {att value} $args {if {$att eq "-name"} {set name $value}}
:createOrConfigure [:id $name] $args
}
}
EntityFactory create NextClass \
-tag "class" \
-superclass Entity {
:attribute name
:attribute {methods:multivalued ""} {set :incremental 1}
:object method id {name} {puts stderr ""; return [[:info class] eval {set :root_namespace}]::class::[string trimleft $name :]}
:object method new args {
foreach {att value} $args {if {$att eq "-name"} {set name $value}}
:createOrConfigure [:id $name] $args
}
# @method process
#
# This method implements the provided, yet abstract
# Entity.process() method.
#
# @see Entity#process()
:method process {comment_block} {
puts stderr "+++ comment_block: $comment_block"
}
}
# @class 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 name:required
:attribute partof:required
:attribute use
}
#
# variant and param are Parts:
#
Class create NextCommand::Variant -superclass Part {
:method init {} {${:partof} variants add [self] end}
}
Class create NextCommand::Parameter -superclass Part {
:attribute param
:attribute fullname
:attribute spec
:attribute default
:method init {} {${:partof} params add [self] end}
}
#
# xotclMethod 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.
#
EntityFactory create NextMethod \
-tag "method" \
-superclass Part {
:attribute {scope class}
:attribute {modifier public}
:attribute arguments
:attribute {returns ""}
:object method id {partof scope name} {
return [[:info class] eval {set :root_namespace}]::method::[string trimleft $partof :]::${scope}::${name}
}
:object method new args {
foreach {att value} $args {
if {$att eq "-partof"} {set partof $value}
if {$att eq "-name"} {set name $value}
if {$att eq "-scope"} {set scope $value}
}
if {![info exists scope]} {
if {[::next::core::objectproperty $partof class]} {
set scope class
} elseif {[::next::core::objectproperty $partof object]} {
set scope object
} else {
set scope class
}
}
:createOrConfigure [:id $partof $scope $name] $args
}
:method init {} {[NextClass id ${:partof}] methods add [self] end}
:method signature {} {
if {[info exists :arguments]} {
set arguments ${:arguments}
} else {
set arguments [list]
foreach p [:params] {lappend arguments [$p param]}
}
set result "obj ${:name} $arguments"
}
}; # NextMethod
namespace export EntityFactory NextCommand NextClass NextMethod @
}
namespace eval ::next::doc {
#
# Provide a simple HTML renderer. For now, we make our life simple
# by defining for the different supported docEntities different methods.
#
# We could think about a java-doc style renderer...
#
Class create HTMLrenderer {
# render command pieces in the text
:method cmd {text} {return <@TT>$text@TT>}
#
# render xotcl commands
#
:method renderCmd {} {
puts "
[:cmd ${:name}]
\n[:text]"
set variants [sorted [:variants] name]
if {$variants ne ""} {
puts " "
foreach v $variants {puts " - [$v text]"}
puts "
"
}
set params [:params]
if {$params ne ""} {
puts " "
foreach v $params {puts " - [$v cmd [$v name]] [$v text]"}
puts "
"
}
puts "\n"
}
#
# render xotcl classes
#
:method renderClass {} {
puts "[:cmd ${:name}]
\n[:text]"
set methods [sorted [:methods] name]
if {$methods ne ""} {
puts "
Methods of ${:name}:\n "
foreach v $methods {if {[$v scope] eq "class"} {$v renderMethod}}
puts "
"
puts "
Object Methods of ${:name}:\n "
foreach v $methods {if {[$v scope] eq "object"} {$v renderMethod}}
puts "
"
}
puts "\n"
}
#
# render xotcl methods
#
:method renderMethod {} {
puts "[:cmd [:signature]]
\n[:text]"
set params [:params]
if {$params ne ""} {
puts " "
foreach v $params {puts " - [$v cmd [$v name]] [$v text]"}
puts "
"
}
if {${:returns} ne ""} {
puts " Returns: ${:returns}"
}
puts "\n"
}
}
}
#
# post processor for initcmds and method bodies
#
namespace eval ::next {
namespace import -force ::next::doc::*
Object create doc {
:method log {msg} {
puts stderr "[self]->[uplevel 1 [list ::next::core::current proc]]: $msg"
}
# @method process
#
# 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.
#
:method process {thing} {
# TODO: tcl packages as an option?
# 1) in-situ processing: a class object
if {[::next::core::objectproperty $thing class]} {
if {[$thing exists __initcmd]} {
:analyze_initcmd NextClass $thing [$thing eval {set :__initcmd}]
}
} elseif {[::next::core::objectproperty $thing object]} {
# 2) in-situ processing: a non-class object
:log "can't postprocess objects currently"
} elseif {[file isfile $thing]} {
# 3) alien script file
if {[file isreadable $thing]} {
set fh [open $thing r]
if {[catch {set script [read $thing]} msg]} {
:log "error reading the file '$thing', i.e.: '$msg'"
}
} else {
:log "file '$thing' not readable"
}
} else {
# 4) we assume a string block, e.g., to be fed into eval
:analyze $thing
}
}
:method analyze {script} {
set blocks [:comment_blocks $script]
:log "blocks: '$blocks'"
foreach block $blocks {
:log "block: '$block'"
set analyzed_block [:analyze_comment_block $block]
set cb [dict create {*}$analyzed_block]
:log ">>>> $cb"
#
# 1) resolve the entity by tag; e.g.: class -> NextClass
#
set entity [EntityFactory eval set :tags([dict get $cb entity])]
#
# 2) provide an object rep of the entity
#
set entity_instance [@ $entity [dict get $cb [$entity tag]] [dict get $cb text]]
#
# 3) process entity-specific parts, according to their tags
#
$entity_instance process $analyzed_block
}
}
:method analyze_line {line} {
if {[regexp {^\s*$} $line]} {
return 1
} elseif {[regexp {^\s*#} $line]} {
return 2
} else {
return 3
}
}
:method analyze_line {line} {
#
# 1 ... empty line
#
if {[regexp {^\s*$} $line]} {
return 1
} elseif {[regexp {^\s*#\s*@[^[:space:]@]} $line]} {
#
# 2 ... tagged comment line
#
return 2
} elseif {[regexp {^\s*#\s*[^[:space:]]\s*} $line]} {
#
# 3 ... untagged, non-emtpy comment line
#
return 3
} elseif {[regexp {^\s*#} $line]} {
#
# 4 ... untagged, empty comment line
#
return 4
} else {
#
# 5 ... code line
#
return 5
}
}
:method analyze_line {line} {
if {[regexp -- {^\s*#+[#\s]*(.*)$} $line --> comment]} {
return [list 1 [string trim $comment]]
} else {
return [list 0 $line]
}
}
:method append_tag {line} {
set line [:remove_comment_markup $line]
set tag [string trimleft [lindex $line 0] @]
return [list $tag [lrange $line 1 end]]
}
:method comment_blocks {script} {
set lines [split $script \n]
set comment_blocks [list]
set was_comment 0
set spec {
0,1 {set comment_block [list]; lappend comment_block $text}
1,0 {lappend comment_blocks $comment_block}
1,1 {lappend comment_block $text}
0,0 {}
}
array set do $spec
foreach line $lines {
foreach {is_comment text} [:analyze_line $line] break;
eval $do($was_comment,$is_comment)
set was_comment $is_comment
}
return $comment_blocks
}
:method remove_comment_markup {comment} {
regsub -all -line {^\s*#} $comment "" comment
return $comment
}
:method analyze_comment_block {comment} {
set result [list]
set text ""
foreach line [split $comment \n] {
if {[regexp {^ *@(class|attribute|param|returns|method|object-method) (.*)$} $line _ kind value]} {
if {$kind eq "param"} {
if {[regexp {^\s*(\S+)\s+(.*)$} $value _ name desc]} {
set value [list $name $desc]
} else {
puts stderr "invalid param specification $value"
}
}
lappend result entity $kind
lappend result $kind $value
} else {
append text $line
}
}
lappend result text $text
#puts result=$result
return $result
}
# :method comment_blocks {{-mode all} source} {
# set comment_blocks [list]
# set lines [split $source \n]
# # states
# # 1 empty line
# # 2 (pseudo) comment: tag line (2a) vs. text line (2b)
# # 3 code
# set behaviour(all) {
# 1,1 {}
# 1,2 {set comment $line\n}
# 1,3 {}
# 2,1 {lappend comment_blocks [:remove_comment_markup $comment]}
# 2,2 {append comment $line\n}
# 2,3 {lappend comment_blocks [:remove_comment_markup $comment]}
# 3,1 {}
# 3,2 {set comment $line\n}
# 3,3 {}
# }
# set behaviour(first) {
# 1,1 {}
# 1,2 {set comment $line\n}
# 1,3 {set code 1}
# 2,1 {if {!$code} {lappend comment_blocks [:remove_comment_markup $comment]}}
# 2,2 {append comment $line\n}
# 2,3 {if {!$code} {lappend comment_blocks [:remove_comment_markup $comment]}; set code 1}
# 3,1 {}
# 3,2 {set comment $line\n}
# 3,3 {}
# }
# array set actions $behaviour($mode)
# set state 1
# set code 0
# foreach line $lines {
# set nextstate [:analyze_line $line]
# eval $actions($state,$nextstate)
# set state $nextstate
# }
# return $comment_blocks
# }
:method analyze_method_block {-methodName -partof -scope -arguments analyzed_block} {
array set cb $analyzed_block
@ NextMethod $methodName -partof $partof -scope $scope $cb(text)
set m [NextMethod id $partof $scope $methodName]
set docparams [list]
foreach {att value} $analyzed_block {
# we do not handle "use" yet
if {$att eq "param"} {
$m param [lindex $value 0] [lindex $value 1]
lappend docparams [lindex $value 0]
} elseif {$att eq "returns"} {
$m returns $value
}
}
if {$arguments eq ""} {
set arguments $docparams
}
$m arguments $arguments
}
:method analyze_body {-partof -methodName -scope arguments body} {
set blocks [:comment_blocks -mode first $body]
if {[llength $blocks] > 0} {
:analyze_method_block -methodName $methodName -partof $partof -scope $scope \
-arguments $arguments \
[:analyze_comment_block [lindex $blocks 0]]
}
}
:method analyze_initcmd {docKind name initcmd} {
set first_block 1
foreach block [:comment_blocks $initcmd] {
set analyzed_block [:analyze_comment_block $block]
array unset cb
array set cb $analyzed_block
if {$first_block} {
set first_block 0
if {[array size cb] == 1} {
# we got a comment for the doc kind
@ $docKind $name $cb(text)
continue
}
}
if {[info exists cb(method)] || [info exists cb(object-method)]} {
set arguments ""
if {[info exists cb(method)]} {
set methodName $cb(method)
set scope class
catch {set arguments [$name info method args $methodName]}
} else {
set methodName $cb(object-method)
set scope object
catch {set arguments [$name object info method args $methodName]}
}
:analyze_method_block -methodName $methodName -partof $name -scope $scope \
-arguments $arguments $analyzed_block
}
}
foreach methodName [$name info methods -methodtype scripted] {
:analyze_body -partof $name -methodName $methodName -scope class \
[$name info method args $methodName] \
[$name info method body $methodName]
}
foreach methodName [$name object info methods -methodtype scripted] {
:analyze_body -partof $name -methodName $methodName -scope object \
[$name object info method args $methodName] \
[$name object info method body $methodName]
}
}; # ::next::doc object
# activate the recoding of initcmads
::next::core::configure keepinitcmd true
}
}
#
# toplevel interface
# ::next::doc::make all
# ::next::doc::make doc
#
namespace eval ::next::doc {
Object create make {
:method all {{-verbose:switch} {-class ::next::Class}} {
foreach c [$class info instances -closure] {
if {$verbose} {puts "postprocess $c"}
::next::doc::postprocessor process $c
}
}
:method doc {{-renderer ::next::doc::HTMLrenderer}} {
# register the HTML renderer for all docEntities.
Entity mixin add $renderer
puts "Primitive XOTcl framework commands
\n"
foreach cmd [sorted [NextCommand info instances] name] {
$cmd renderCmd
}
puts "
\n\n"
puts "XOTcl Classes
\n"
foreach cmd [sorted [NextClass info instances] name] {
$cmd renderClass
}
puts "
\n\n"
Entity mixin delete $renderer
}
}
#
# modal comment block parsing
#
#
# contexts are entities
#
Object create entity {
set :processed_part context
:method process {comment_block} {
set last_line ""
foreach line $comment_block {
set activity [${:processed_part} transition $line $last_line]
puts stderr activity=$activity
${:processed_part} signal $activity $line
set last_line [${:processed_part} current_comment_line]
}
}
}
#
# Infrastructure for state objects:
#
# 1. CommentState: a base class for sharing behaviour between atomic
# and non-orthogonal super-states; it is widely an intermediate,
# abstracted class, providing a refinement protocol for concrete
# state subclasses
#
Class create CommentState {
:method on_enter {line} {
puts stderr [self]->[::next::core::current proc]
}
:method on_exit {line} {
puts stderr [self]->[::next::core::current proc]
}
:method signal {event line} {;}
#
# activity/event interface
#
:method event=process {line} {;}
:method event=close {line} {;}
:method event=next {line} {;}
:method event=exit {msg} {
error $msg
}
}
# 2. CommentLines represent atomic states in the parsing state
# machinery: tag, text, space
Class create CommentLine -superclass CommentState {
:attribute comment_part; # points to the super-state objects
:forward signal {% ${:comment_part} } %proc
:method match {line} {;}
:method is? {line} {
foreach cline [[:info class] info instances] {
if {[$cline match $line]} {
return [namespace tail $cline]
}
}
}
}
CommentLine create tag {
:method match {line} {
set tag [lindex $line 0]
return [expr {[string first @ $tag] == 0}]
}
:method event=process {line} {
# 1. is it a valid tag line?
set tag [lindex $line 0]
# 2. get the tag label, its value, and the remainder text
puts stderr tag=[string trimleft @ $tag],value=[lindex $line 1],text=[lrange $line 2 end]
}
}
CommentLine create text {
:method match {line} {
return [regexp -- {[^[:space:]@]+} $line]
}
:method event=process {line} {
puts stderr text=$line
}
}
CommentLine create space {
:method match {line} {
return [expr {$line eq {}}]
}
}
#
# 3. CommentParts represent orthogonal super-states over
# CommentLines: context, description, part
#
Class create CommentPart -superclass CommentState {
:attribute current_comment_line:required
:attribute comment_line_transitions
:attribute next_comment_part; # implements a STATE-OWNED TRANSITION scheme
:method init {} {
${:current_comment_line} comment_part [self]
}
:method transition {line {source_state ""}} {
array set transitions ${:comment_line_transitions}
if {$source_state eq ""} {
set actual_target_state ${:current_comment_line}
} else {
set actual_target_state [$source_state is? $line]
}
puts stderr "+++ info exists transitions(${source_state}->${actual_target_state})"
if {![info exists transitions(${source_state}->${actual_target_state})]} {
error "Style violation in a [namespace tail [self]] section: A $source_state line is followed by a $actual_target_state line."
}
set :current_comment_line ${actual_target_state}
return $transitions(${source_state}->${actual_target_state})
}
:method on_enter {line} {
next
if {![info exists :current_comment_line]} {
set :current_comment_line [:transition $line]
}
${:current_comment_line} [::next::core::next proc]
}
:method on_exit {} {
${:current_comment_line} [::next::core::next proc]
next
}
:method signal {event line} {
:event=$event $line
${:current_comment_line} event=$event $line
}
#
# handled events
#
:method event=next {} {;}
}; # CommentPart
#
# the OWNER-DRIVEN TRANSITIONS read as follows:
# . { }
#
CommentPart create context \
-next_comment_part description \
-comment_line_transitions {
->tag process
tag->text process
text->text process
text->space next
tag->space next
} \
-current_comment_line tag
CommentPart create description \
-next_comment_part part \
-comment_line_transitions {
->text process
text->text process
text->space space next
} \
-current_comment_line text
CommentPart create part \
-next_comment_part part \
-comment_line_transitions {
->tag process
tag->text process
text->text process
text->tag next
text->space next
tag->tag next
} \
-current_comment_line tag
}
puts stderr "Doc Tools loaded: [info command ::next::doc]"