# @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::*

  #
  # 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 ExceptionClass -superclass Class {
    :method behind? {error_msg} {
      return [expr {[::nx::core::is $error_msg object] && \
			[::nx::core::is $error_msg type [self]]}]
    }
    :method thrown_by? {script} {
      if {[uplevel 1 [list ::catch $script msg]]} {
	return [:behind? [uplevel 1 [list set msg]]]
      }
      return 0
    }

  }

  ExceptionClass create Exception {
    :attribute message:required
    :attribute stack_trace 

    :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
  ExceptionClass create InvalidTag -superclass Exception
  ExceptionClass create MissingPartofEntity -superclass Exception 


  Class create EntityClass -superclass Class {
    #
    # EntityClass is a meta-class for named doc entities
    #
    :attribute {tag {[string tolower [namespace tail [self]]]}}
    :attribute {root_namespace "::nx::doc::entities"}

    namespace eval ::nx::doc::entities {}

    :method id {name} {
      set subns [string trimleft [namespace tail [self]] @]
      return [:root_namespace]::${subns}::[string trimleft $name :]
    }

    :method new_from_attribute {tag domain args} {
      :new {*}$args
    }

    :method new {-name:required args} {
      :createOrConfigure [:id $name] -name $name {*}$args
    }

    :method createOrConfigure {id args} {
      namespace eval $id {}
      if {[::nx::core::objectproperty $id object]} {
	$id configure {*}$args
      } else {
	:create $id {*}$args
      }
      return $id
    }
  }

  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 {-partof -part_attribute -name args} {
      :createOrConfigure [:id [$partof name] [$part_attribute scope] $name] {*}[self args]
    }
  }
  
  # @object 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 {

    # @attribute 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]} {
	regexp -- {@(.*)-.*} [namespace tail [self]] _ :scope
      }
      next
    }
    
    :method get_part {domain prop value} {
      if {[info exists :part_class]} {
	if {[::nx::core::is $value object] && \
		[::nx::core::is $value type ${:part_class}]} {
	  return $value
	}
	  set part [${:part_class} new \
			       -name [lindex $value 0] \
			       -partof $domain \
			       -part_attribute [self] \
			       -@doc [lrange $value 1 end]]
	
	return $part
	
      }
      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 [:get_part $domain $prop $v]
      }
      next $domain $prop $parts
    }
    :method add {domain prop value {pos 0}} {
      set p [:get_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 [:get_part $prop $value]
    }
  }
  


  Class create Entity {
    #
    # Entity is the base class for the documentation classes
    #

    :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
    :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 {} {
      # TODO: Provide \n replacements for empty lines
      subst [join ${:@doc} " "]
    }
    
  }

  #
  # 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
  #  - @attribute
  #  - ...
  #

  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 {
      set :part_class @param
    }
  }
  
  EntityClass create @object \
      -superclass Entity {
	:attribute @author -slotclass ::nx::doc::PartAttribute 
	:attribute @method -slotclass ::nx::doc::PartAttribute {
	  set :part_class @method
	}
	:attribute @object-method -slotclass ::nx::doc::PartAttribute {
	  set :part_class @method
	}
	:attribute @attribute -slotclass ::nx::doc::PartAttribute {
	  set :part_class @attribute
	}
	
	: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 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
  }

  #
  # @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}
	:attribute @param -slotclass ::nx::doc::PartAttribute {
	  set :part_class @param
	}
	:attribute @return -slotclass ::nx::doc::PartAttribute {
	  set :part_class @param
	}
	
	: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
	      } {
	  set partof_entity [$partof name]
	  # scoping checks: is the scope requested (from the
	  # part_attribute) applicable to the partof object, which is
	  # the object behind [$partof name]
	  if {![$part_attribute exists scope]} {
	    if {[::nx::core::objectproperty $partof_entity class]} {
	      $part_attribute scope class
	    } elseif {[::nx::core::objectproperty $partof_entity object]} {
	      $part_attribute scope object
	    } else {
	      $part_attribute scope class
	    }
	  }
	  next
	}
	
	: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"
	}
	:method process {	  
	  {-initial_section:optional "context"} 
	  comment_block
	} {
	  next \
	      -initial_section $initial_section \
	      -entity [self] $comment_block
	}

      }; # @method
  

  # TODO: Refactor @attribute into a variant of @param, having an
  # object scope; along with command and method scopes. Or, is it
  # really scopes or is it sufficient to navigate along the partof
  # relationship?
  PartClass create @attribute \
      -superclass Part {
	
	: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
	      } {
	  set partof_entity [$partof name]
	  # scoping checks: is the scope requested (from the
	  # part_attribute) applicable to the partof object, which is
	  # the object behind [$partof name]
	  if {![$part_attribute exists scope]} {
	    if {[::nx::core::objectproperty $partof_entity class]} {
	      $part_attribute scope class
	    } elseif {[::nx::core::objectproperty $partof_entity object]} {
	      $part_attribute scope object
	    } else {
	      $part_attribute scope class
	    }
	  }
	  next
	}


      }; # @attribute

  #
  # TODO: retrofit @command::Variant
  # 
  Class create @command::Variant -superclass Part

  EntityClass create @param \
      -superclass Part {
	:attribute param
	:attribute fullname    
	:attribute spec
	:attribute default

	:object method id {partof name} {
	  return [:root_namespace]::${:tag}::${partof}::${name}
	}

	:object method new_from_attribute {tag domain args} {
	  array set "" $args
	  set (-partof) $domain
	  :new {*}[array get ""]
	}
	
	: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
	      } {
	  set scope [namespace tail [namespace qualifiers $partof]]
	  :createOrConfigure [:id "${scope}[${partof} name]" $name] {*}[self args]
	}
      }

  namespace export EntityClass @command @object @method @param \
      @attribute @package @ Exception StyleViolation InvalidTag \
      MissingPartofEntity
}



namespace eval ::nx::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 "<LI>[:cmd ${:name}] <br>\n[:text]"
      set variants [sorted [:variants] name]
      if {$variants ne ""} {
	puts "   <UL>"
	foreach v $variants {puts "    <LI>[$v text]"}
	puts "   </UL>"
      }
      set params [:params]
      if {$params ne ""} {
	puts "   <UL>"
	foreach v $params {puts "    <LI>[$v cmd [$v name]] [$v text]"}
	puts "   </UL>"
      }
      puts "</LI>\n"
    }

    #
    # render next classes
    #
    :method renderClass {} {
      puts "<LI>[:cmd ${:name}] <br>\n[:text]"
      set methods [sorted [:methods] name]
      if {$methods ne ""} {
	puts "<br>Methods of ${:name}:\n   <UL>"
	foreach v $methods {if {[$v scope] eq "class"} {$v renderMethod}}
	puts "   </UL>"
	puts "<br>Object Methods of ${:name}:\n   <UL>"
	foreach v $methods {if {[$v scope] eq "object"} {$v renderMethod}}
	puts "   </UL>"
      }
      puts "</LI>\n"
    }

    #
    # render next methods
    #
    :method renderMethod {} {
      puts "<LI>[:cmd [:signature]] <br>\n[:text]"
      set params [:params]
      if {$params ne ""} {
	puts "   <UL>"
	foreach v $params {puts "    <LI>[$v cmd [$v name]] [$v text]"}
	puts "   </UL>"
      }
      if {${:returns} ne ""} {
	puts "   Returns: ${:returns}"
      }
      puts "\n"
    }

  }

}

#
# post processor for initcmds and method bodies
#
namespace eval ::nx {
  namespace import -force ::nx::doc::*
  ::nx::Object create doc  {

    :method log {msg} {
      puts stderr "[self]->[uplevel 1 [list ::nx::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} {
      # 1) in-situ processing: a class object
      if {[::nx::core::objectproperty $thing object]} {
        if {[$thing exists __initcmd]} {
          :analyze_initcmd @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 next::doc
	  namespace import -force ::nx::*; 
	  ::nx::Class create SourcingTracker {
	    :method create args {
	      [::nx::core::current class] eval {
		if {[info exists :scripts]} {
		  set :scripts [dict create]
		}
	      } 
	      [::nx::core::current class] eval [list dict set :scripts [info script] _];
	      next;
	    }
	  } 
	  ::nx::Object mixin add SourcingTracker
	  package forget $thing; 
	  package req $thing
	  ::nx::Object mixin delete SourcingTracker
	  set sourced_scripts [SourcingTracker eval {dict keys \${:scripts}}]
	  foreach script \$sourced_scripts {
	    doc process \$script
	  }
	  
	}]
	interp eval $i $cmd
	return $i
      } elseif {[file isfile $thing]} {
	# 3) alien script file
	if {[file readable $thing]} {
	  set fh [open $thing r]
	  if {[catch {set script [read $fh]} msg]} {
	    catch {close $fh}
	    :log "error reading the file '$thing', i.e.: '$msg'"
	  }
	  close $fh
	  doc analyze $script
	} else {
	  :log "file '$thing' not readable"
	}
      } else {
	# 4) we assume a string block, e.g., to be fed into eval
	set i [interp create]
	set cmd [subst {
	  package req next::doc
	  namespace import -force ::nx::doc::*
	  doc analyze [list $thing]
	}]
	interp eval $i $cmd
	#interp delete $i
	return $i
      }
    }

    :method analyze {script} {
      # NOTE: This method is to be executed in a child/ slave
      # interpreter.
      set pre_commands [:list_commands]
      uplevel #0 [list namespace import -force ::nx::doc::*]
      uplevel #0 [list eval $script]
      set post_commands [:list_commands]
      set additions [dict keys [dict remove [dict create {*}"[join $post_commands " _ "] _"] {*}$pre_commands]]

      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
	if {[catch {::nx::doc::EntityClass process $block} msg]} {
	  if {![StyleViolation behind? $msg] && ![MissingPartofEntity behind? $msg]} {
	    if {[Exception behind? $msg]} {
	      error [$msg info class]->[$msg message]
	    }
	    error $msg
	  }
	}
      }
      # 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 {![::nx::core::is $addition object]} continue;
	:process $addition
      }
    }

    :method list_commands {{parent ::}} {
      set cmds [info commands ${parent}::*]
      foreach nsp [namespace children $parent] {
	lappend cmds {*}[:list_commands ${nsp}]
      }
      return $cmds
    }

    :method analyze_line {line} {
      set regex {^\s*#+[#\s]*(.*)$}
      if {[regexp -- $regex $line --> comment]} {
	return [list 1 [string trim $comment]]
      } else {
	return [list 0 $line]
      }
    }
    
    :method comment_blocks {script} {
      set lines [split $script \n]
      set comment_blocks [list]
      set was_comment 0
      set spec {
	0,1	{
	  set line_offset $line_counter; 
	  set comment_block [list]; 
	  lappend comment_block $text}
	1,0	{lappend comment_blocks $line_offset $comment_block}
	1,1	{lappend comment_block $text}
	0,0	{}
      }
      array set do $spec 
      set line_counter -1
      foreach line $lines {
	incr line_counter
	# foreach {is_comment text} [:analyze_line $line] break;
	lassign [:analyze_line $line] is_comment text;
	eval $do($was_comment,$is_comment)
	set was_comment $is_comment
      }
      return $comment_blocks
    }
	   
    :method analyze_initcmd {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?!
	if {[catch {$id process {*}$arguments} msg]} {
	  lappend failed_blocks $line_offset
	}
      }
      
    }; # analyze_initcmd method
    
    
    # activate the recoding of initcmds
    ::nx::core::configure keepinitcmd true
    
  }
}
	  

#
# toplevel interface
#   ::nx::doc::make all
#   ::nx::doc::make doc
#
namespace eval ::nx::doc {

  Object create make  {
    
    :method all {{-verbose:switch} {-class ::nx::Class}} {
      foreach c [$class info instances -closure] {
	if {$verbose} {puts "postprocess $c"}
	::nx::doc::postprocessor process $c
      }
    }
    
    :method doc {{-renderer ::nx::doc::HTMLrenderer}} {
      
      # register the HTML renderer for all docEntities.
      
      Entity mixin add $renderer
      
      puts "<h2>Primitive XOTcl framework commands</h2>\n<UL>"
      foreach cmd [sorted [@command info instances] name] {
	$cmd renderCmd
      }
      puts "</UL>\n\n"
      
      puts "<h2>XOTcl Classes</h2>\n<UL>"
      foreach cmd [sorted [@object info instances] name] {
	$cmd renderClass
      }
      puts "</UL>\n\n"
      
      Entity mixin delete $renderer
    }
  }
  
  #
  # modal comment block parsing
  #
  
  #
  # contexts are entities
  #
  EntityClass eval {
    :object forward has_next expr {${:idx} < [llength ${:comment_block}]}
    :object method dequeue {} {
      set r [lindex ${:comment_block} ${:idx}]
      incr :idx
      return $r
    }
    :object forward rewind incr :idx -1
    :object forward fastforward set :idx {% expr {[llength ${:comment_block}] - 1} }
    :object method process {
	{-partof_entity:optional ""}
	{-initial_section:optional context}
	-entity:optional
	block
      } {
      set :comment_block $block
      
      # initialise the context object
      set :processed_section $initial_section
      set :partof_entity $partof_entity      
      
      if {[info exists :current_entity]} {
	unset :current_entity
      }
      
      if {[info exists entity]} {
	set :current_entity $entity
      }
      
      set :is_not_completed 1
      
      ${:processed_section} eval [list set :context [self]]
      set is_first_iteration 1
      set :idx 0
      set failure ""
      while {${:is_not_completed}} {
	set line [:dequeue]	
	if {$is_first_iteration} {
	  ${:processed_section} on_enter $line
	  set is_first_iteration 0
	}

	if {[catch {${:processed_section} transition $line} failure]} {
	  set :is_not_completed 0
	  #
	  # TODO: For now, the fast-forward mechanism jumps to the end
	  # of the comment block; this avoids redundant on_exit
	  # calls. is there a better way of achieving this?
	  #
	  :fastforward
	} else {
	  set :is_not_completed [:has_next]
	}
      }
      if {!$is_first_iteration} {
	${:processed_section} on_exit $line
      }
      
      if {$failure ne ""} {
	error $failure
      }
      
      return ${:current_entity}
    }
    
    :object method resolve_partof_entity {tag name} {
      # a) unqualified: attr1
      # b) qualified: Bar#attr1
      if {[regexp -- {([^\s#]*)#([^\s#]*)} $name _ qualifier nq_name]} {
	# TODO: Currently, I only foresee @object as possible
	# qualifier; however, this should be fixed asap, as soon as
	# the variety of entities has been decided upon!
	set partof_entity [@object id $qualifier]
	# TODO: Also, we expect the qualifier to resolve against an
	# already existing entity object? Is this intended?
	if {[::nx::core::is $partof_entity object]} {
	  return [list $nq_name $partof_entity]
	} else {
	  return [list $nq_name ${:partof_entity}]
	}
      } else {      
	return [list $name ${:partof_entity}]
      }
    
    }
    :object method dispatch {tag args} {

      if {![info exists :current_entity]} {
	# 1) the current (or context) entity has NOT been resolved
	#
	# for named entities, the provided identifier can be either
	# qualified or unqualified:
	# 
	# a) unqualified: @attribute attr1
	# b) qualified: @attribute Bar#attr1
	#
	# For qualified ones, we must resolve the qualifier to serve
	# as the partof_entity; see resolve_partof_entity()

	set name [lindex $args 0]
	set args [lrange $args 1 end]
	lassign [:resolve_partof_entity $tag $name] nq_name partof_entity;

	if {$partof_entity ne ""} {
	  if {[$partof_entity info callable -application $tag] eq ""} {
	    [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"
	  set :current_entity [$partof_entity $tag $nq_name {*}$args]
	  
	} else {
	  set qualified_tag [namespace qualifiers [self]]::$tag
	  if {[EntityClass info instances -closure $qualified_tag] eq ""} {
	    [InvalidTag new -message [subst {
	      The entity type '$tag' is not available
	    }]] throw 
	  }
	  puts stderr "$tag new -name $nq_name {*}$args"
	  set :current_entity [$tag new -name $nq_name {*}$args]
	}
      } else {
	# 2) current (or context) entity has been resolved
	# TODO: Should we explicitly disallow qualified names in parts?
	if {[${:current_entity} info callable -application $tag] eq ""} {
	  [InvalidTag new -message [subst {
	    The tag '$tag' is not supported for the entity type
	    '[namespace tail [${:current_entity} info class]]'
	  }]] throw
	}
	puts stderr "${:current_entity} $tag {*}$args"
	${:current_entity} $tag {*}$args
      }
    }
  }


  
  #
  # 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 {
    :attribute context; # points to the context object, i.e., an entity
    :method on_enter {line} {;}
      
    :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
    }
    :method event=rewind {line} {;}
  }
  
  # 2. CommentLines represent atomic states in the parsing state
  # machinery: tag, text, space
  
  Class create CommentLine -superclass CommentState {
    :attribute comment_section; # points to the super-state objects
    :attribute processed_line; # stores the processed text line
    :forward signal {% ${:comment_section} } %proc
    :forward context {% ${:comment_section} } %proc
    :forward current_entity {% :context } eval set :current_entity
    
    :method on_enter {line} {;}
    :method on_exit {line} {;}
        
    :method match {line} {;}
    :method is? {line} {
      foreach cline [lsort [[: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} {
      set tag [lindex $line 0]
      [:context] dispatch $tag [lrange $line 1 end]
    }
    
  }
  
  CommentLine create text {
    :method match {line} {
      return [regexp -- {\s*[^[:space:]@]+} $line]
    }
    :method event=process {line} {
      [:context] dispatch @doc add $line end
    }
    
  }
  
  CommentLine create space {
    :method match {line} {
      return [expr {$line eq {}}]
    }
  }
  
  
  #
  # 3. CommentSections represent orthogonal super-states over
  # CommentLines: context, description, part
  #
  
  Class create CommentSection -superclass CommentState {
    :attribute entry_comment_line:required
    :attribute current_comment_line
    :attribute comment_line_transitions
    :attribute next_comment_section; # implements a STATE-OWNED TRANSITION scheme
    
    :method init {} {
      ${:entry_comment_line} comment_section [self]
    }
    
    :method transition {line} {
      array set transitions ${:comment_line_transitions}
      
      if {![info exists :current_comment_line]} {
	set src ""
	set tgt [${:entry_comment_line} is? $line]
      } else {
	set src ${:current_comment_line}
	set tgt [$src is? $line]
      }
      
      #
      # TODO: realise the initial state nodes as NULL OBJECTs, this
      # helps avoid conditional branching all over the place!
      #
      if {$src ne ""} {
	$src on_exit $line;
      }
      if {![info exists transitions(${src}->${tgt})]} {
	set msg "Style violation in a [namespace tail [self]] section:\n"
	if {$src eq ""} {
	  append msg "Invalid first line ('${tgt}')"
	} else {
	  append msg "A ${src} line is followed by a ${tgt} line"
	}
	[StyleViolation new -message $msg] throw
      }
      
      set :current_comment_line $tgt
      $tgt comment_section [self]
      ${:current_comment_line} processed_line $line
      ${:current_comment_line} on_enter $line
      
      #foreach {event activities} $transitions(${src}->${tgt}) break;
      lassign $transitions(${src}->${tgt}) event activities;
      :signal $event $line
      foreach activity $activities {
	:signal $activity $line
      }
    }
    
    :method on_enter {line} {;}
    
    :method on_exit {line} {
      # TODO: move this behaviour into a more decent place
      if {![${:context} has_next]} {
	${:current_comment_line} on_exit $line
      }
      # Note: Act passive here, because e.g. upon invalid entry
      # state transition requests, there is no current_comment_line
      # set here. Yet, we want to exit from the comment section!
      if {[info exists :current_comment_line]} {
	unset :current_comment_line
      }
      next;
    }
    
    :method signal {event line} {
      ${:current_comment_line} event=$event $line
      :event=$event $line
    }
    
    #
    # handled events
    #
    :method event=next {line} {
      set next_section [:next_comment_section]
      ${:current_comment_line} on_exit $line
      :on_exit $line
      $next_section eval [list set :context ${:context}]
      $next_section on_enter $line
      ${:context} eval [list set :processed_section [:next_comment_section]]      
      
    }
    
    :method event=rewind {line} {
      ${:context} rewind
      next
    }
    
  }; # CommentSection
  
  
  #
  # the OWNER-DRIVEN TRANSITIONS read as follows:
  # (current_state)->(next_state) {event {activity1 activty2 ...}}
  #
  
  #
  # TODO: refactor {close {rewind next}} into a single activity
  #
  
  #
  # context
  #
  CommentSection create context \
      -next_comment_section description \
      -comment_line_transitions {
	->tag		{process ""}
	tag->space	{process ""}
	space->space	{process ""}
	space->text	{close {rewind next}}
	space->tag	{close {rewind next}}
      } -entry_comment_line tag
  
  # NOTE: add these transitions for supporting multiple text lines for
  # the context element
  #	tag->text	{process ""}
  #	text->text	{process ""}
  #	text->space	{process ""}
  
  #
  # description
  #
  CommentSection create description \
      -next_comment_section part \
      -comment_line_transitions {
	->text		{process ""}
	->tag		{close {rewind next}}
	text->text	{process ""}
	text->space	{process ""}
	space->text	{process ""}
	space->space	{process ""}
	space->tag	{close {rewind next}}
      } -entry_comment_line text {
	:method on_enter {line} {
	  #
	  # TODO: fix the re-set of the @doc attribute
	  #
	  if {[${:context} exists :current_entity]} {
	    ${:context} eval {
	      ${:current_entity} eval {
		unset -nocomplain :@doc
	      }
	    } 
	  }
	  next;
	}
      }
  
  #
  # part
  # 
  CommentSection create part \
      -next_comment_section part \
      -comment_line_transitions {
	->tag		{process ""}
	tag->text	{process ""}
	text->text	{process ""}
	text->tag	{close {rewind next}}
	text->space	{process ""}
	space->space	{process ""}
	tag->space	{process ""}
	space->tag	{close {rewind next}}
	tag->tag	{close {rewind next}}
      } -entry_comment_line tag 
}

puts stderr "Doc Tools loaded: [info command ::nx::doc::*]"