# @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., @package)
  # @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
  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
  #
  # @param instances Points to a list of entity instances to sort
  # @param sortedBy Indicates the attribte name whose values the sorting will be based on
  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 trimleft [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 {-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
    }

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

    :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
      if {[info exists :@doc]} {
	#
	# Here, we apply a second [join] to compensate for the @doc items
	# being lists themselves (that is, quotes etc. might be escaped)
	#
	subst [join [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 {
      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
	  :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 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
  }

  #
  # @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
	}
	:method signature {} {
	  #
	  # TODO: What was the original intention of introducing arguments?!
	  #
	  if {[info exists :arguments]} {
	    set arguments ${:arguments}
	  } else {
	    set arguments [list]
	    foreach p [:@param] {lappend arguments [$p name]}
	  }
	  set result "method ${:name} $arguments"
	}
	:method process {	  
	  {-initial_section:optional "context"} 
	  comment_block
	} {
	  next \
	      -initial_section $initial_section \
	      -entity [self] $comment_block
	}

      }; # @method
  
  #
  # TODO: retrofit @command::Variant
  # 
  Class create @variant -superclass Part

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

	:object method id {partof name} {
	  set partof_fragment [:get_unqualified_name ${partof}]
	  return [:root_namespace]::${:tag}::${partof_fragment}::${name}
	}
	
	: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
	      } {
	  :createOrConfigure [:id $partof $name] {*}[self args]
	}
      }

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



namespace eval ::nx::doc {

  Class create TemplateData {
    :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]]
    }
    
    #
    #
    #
 
    :object method find_asset_path {{-subdir lib/doc-assets}} {
      foreach dir $::auto_path {
	set assets [file normalize [file join $dir $subdir]]
	if {[file exists $assets]} {
	  return $assets
	}
      }
    }

    :object method read_tmpl {path} {
      if {[file pathtype $path] ne "absolute"} {
	set assetdir [:find_asset_path]
	set tmpl [file join $assetdir $path]
      } else {
	set tmpl [file normalize $path]
      }
      if {![file exists $tmpl] || ![file isfile $tmpl]} {
	error "The template file '$path' was not found."
      }
      set fh [open $tmpl r]
      set content [read $fh]
      catch {close $fh}
      return $content
    }

  }
  
  #
  # 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 Renderer {
    :method render {} {
      :render=[namespace tail [:info class]]
    }
  }

  Class create HtmlRenderer -superclass Renderer {
    # render command pieces in the text
    :method tt {text} {return <@TT>$text</@TT>}


    :method render=@package {} {
      puts "<LI>[:tt ${:name}] <br>\n[:text]"
      set req [:@require]
      if {$req ne ""} {
	puts "   <UL>"
	foreach r $req {puts "    <LI>$r</LI>"}
	puts "   </UL>"
      }
      puts "</LI>\n"

    }

    #
    # render xotcl commands
    #
    :method render=@command {} {
      puts "<LI>[:tt ${: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 [:@param]
      if {$params ne ""} {
	puts "   <UL>"
	foreach v $params {puts "    <LI>[$v tt [$v name]] [$v text]"}
	puts "   </UL>"
      }
      puts "</LI>\n"
    }

    #
    # render next classes
    #
    :method render=@object {} {
      puts "<LI>[:tt ${:name}] <br>\n[:text]"
      if {[info exists :@method]} {
	set methods [sorted [:@method] name]
	if {$methods ne ""} {
	  puts "<br>Methods of ${:name}:\n   <UL>"
	  foreach m $methods {$v render}
	  puts "   </UL>"
	}
      }
      if {[info exists :@object-method]} {
	set methods [sorted [:@object-method] name]
	if {$methods ne ""} {
	  puts "<br>Object methods of ${:name}:\n   <UL>"
	  foreach m $methods {$v render}
	  puts "   </UL>"
	}
      }
      puts "</LI>\n"
    }

    #
    # render next methods
    #
    :method render=@method {} {
      puts "<LI>[:tt [:signature]] <br>\n[:text]"
      set params [:@param]
      if {$params ne ""} {
	puts "   <UL>"
	foreach v $params {puts "    <LI>[$v tt [$v name]] [$v text]"}
	puts "   </UL>"
      }
      if {${:returns} ne ""} {
	puts "   Returns: ${:@return}"
      }
      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]]
      puts stderr ADDITIONS=$additions
      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 [namespace origin $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]; 
	  # Note, we use [split] here to avoid stumbling over
	  # uncommented script blocks which contain pairs of curly
	  # braces which appear scattered over several physical lines
	  # of code. This avoids "unmatched open brace" failures when
	  # feeding each physical line to a list command (later, in
	  # the parsing machinery)
	  lappend comment_block [split $text]}
	1,0	{lappend comment_blocks $line_offset $comment_block}
	1,1	{lappend comment_block [split $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}
      {-outdir /tmp/}
    } {
      
      # register the HTML renderer for all docEntities.
      
      Entity mixin add $renderer

      puts "<h2>Tcl packages</h2>\n<UL>"
      foreach pkg [sorted [@package info instances] name] {
	$pkg render
      }

      
      puts "<h2>Primitive Next framework commands</h2>\n<UL>"
      foreach cmd [sorted [@command info instances] name] {
	$cmd render
      }
      puts "</UL>\n\n"
      
      puts "<h2>Next objects</h2>\n<UL>"
      foreach cmd [sorted [@object info instances] name] {
	$cmd render
      }
      puts "</UL>\n\n"
      
      Entity mixin delete $renderer
    }
   
    :method write {content path} {
      set fh [open $path w]
      puts $fh $content
      catch {close $fh}
    }

    :method doc {
      {-renderer ::nx::doc::HtmlRenderer}
      {-outdir /tmp/}
      {-tmpl entity.html.tmpl}
      {-project {url http://www.next-scripting.org/ name Next}}
    } {
      array set prj $project
      set project [@project new -name $prj(name) -url $prj(url)]
      Entity mixin add $renderer
      set ext [lindex [split [file tail $tmpl] .] end-1]
      set entities [concat [sorted [@package info instances] name] \
			[sorted [@command info instances] name] \
			[sorted [@object info instances] name]]
      set init [subst -nocommands {
	set project $project
      }]

      if {![catch {file mkdir [file join $outdir [$project name]]} msg]} {
	file copy -force -- [$renderer find_asset_path] [file join $outdir [$project name]]/assets
	set index [$project render -initscript $init $tmpl]
	:write $index [file join $outdir [$project name] "index.$ext"]
	foreach e $entities {
	  set content [$e render -initscript $init $tmpl]
	  :write $content [file join $outdir [$project name] "[$e filename].$ext"]
	}
      }
            
      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 ""} {
	#puts stderr ERRORINFO=$::errorInfo
	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: @param attr1
	# b) qualified: @param 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::*]"