# Commenter - a utility to parse tcl source files and associate out-line
# comments with procs.
#
    
package require fileutil
package provide Commenter 1.0
    
namespace eval Commenter {
    
    # gather leading comment block
    proc leadin {text} {
    	set leadin {}
    	set lnum 0
    	foreach line $text {
    	    set line [string trim $line " \t"]
    	    incr lnum
    	    if {[string match \#* $line]} {
    		lappend leadin $line
    	    } else {
    		return [list $leadin [lrange $text $lnum end]]
    	    }
    	}
    	return [list $leadin {}]
    }
    
    # parse a tcl source into a dict containing:
    # provides - the package provided by this source
    # requires - the packages required by this source
    # contexts - the contexts provided by this source (namespace, global, snit)
    # entities - the procs, vars, options and methods provided by this source
    
    proc parse {text} {
    	set text [split $text \n]
    
    	# leadin is a comment block terminated by a non-comment
    	lassign [leadin $text] leadin text
    	set lnum [llength $leadin]
    	#puts stderr "$lnum line leadin"
    
    	set comment {}	;# free-standing comment block
    	set current ""	;# current context
    	array set context [list "" [list name "" type global comment $leadin]]	;# context of declaration
    
    	set requires {} ;# packages required
    	set provides ""	;# package provided
    	set accum ""	;# we're not in proc scope
    
    	foreach line $text {
    	    set line [string trim $line " \t"]
    	    incr lnum
    
    	    if {$accum ne ""} {
    		# we're in proc context
    		append accum \n $line
    		#puts stderr $accum
    		if {![info complete $accum]} {
    		    continue
    		} else {
    		    set accum ""	;# we're out of proc context
    		}
    	    }
    
    	    switch -glob -- $line {
    		\#* {
    		    # accumulate comments en bloc
    		    lappend comment $line
    		}
    
    		package* {
    		    # provide
    		    # require
    		    regsub {[ \t]+} $line " " line
    		    set line [split $line]
    		    switch -- [lindex $line 1] {
    			provide {
    			    set provides [lindex $line 2]
    			    #puts stderr "provides $provides"
    			}
    			require {
    			    if {[string match -* [lindex $line 2]]} {
    				lappend requires [lindex $line 3]
    			    } else {
    				lappend requires [lindex $line 2]
    			    }
    			    #puts stderr "requires $requires"
    			}
    		    }
    		    set comment {}
    		}
    
    		namespace* {
    		    # eval
    		    regsub {[ \t]+} $line " " line
    		    set line [split $line]
    		    if {[lindex $line 1] eq "eval"} {
    			set name [lindex $line 2]
    			set context($name) [list name $name comment $comment type namespace]
    			set current $name
    			set comment {}
    		    }
    		    #puts stderr "namespace $name"
    		}
    
    		snit::type* {
    		    regsub {[ \t]+} $line " " line
    		    set line [split $line]
    		    set name [lindex $line 1]
    		    set context($name) [list name $name comment $comment type snit]
    		    #puts stderr "snit $name"
    		}
    
    		variable* -
    		option* -
    		method* -
    		proc* {
    		    regsub {[ \t]+} $line " " line
    		    set accum $line	;# enter proc context
    
    		    set line [split $line]
    		    set name [lindex $line 1]
    		    if {[lindex $line 0] in {variable option}} {
    			set trailing [lindex [split [join $line] \#] 1]
    			lappend comment $trailing
    		    }
    		    set entities($name) [list name $name comment $comment line $lnum context $current type [lindex $line 0]]
    		    set comment {}
    		    #puts stderr "[lindex $line 0] $name"
    		}
    	    }
    	}
    	return [list contexts [array get context] entities [array get entities] provides $provides requires $requires]
    }
    
    # same as parse, but operates on the contents of a file
    proc parseF {path} {
    	return [parse [::fileutil::cat $path]]
    }
    
    namespace export -clear *
    namespace ensemble create -subcommands {}
}
    
if {[info exists argv0] && ($argv0 eq [info script])} {
    set path [info script]
    puts stderr [Commenter parseF $path]
}