### BEGIN COPYRIGHT BLURB
#
#   TAO - Tcl Architecture of Objects
#   Copyright (C) 2007 Sean Woods
#
#   See the file "license.terms" for information on usage and redistribution
#   of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
### END COPYRIGHT BLURB

###
#  Class Definition Parser
###
 
package require listutil

namespace eval ::tao {
    ###
    #  Storage namespace for objects
    ### 
    namespace eval ::tao::object {}
    namespace eval ::tao::class  {}
}

set ::tao::compiled_classes {}

namespace eval ::tao {
    set ::tao(chain_count) 0
    variable library_file {}

    proc class_exists {classname {load 0}} { 
	set dictname [object_dict $classname]
	if ![info exists $dictname]  {
	    return 0
	}
	return [dict exists [set $dictname] ancestors]
    }

    proc class_method_create {classname method type arglist prebody body} {
	set dictname [object_dict $classname]
	dict set $dictname method $method type $type
	dict set $dictname method $method arglist $arglist
	dict set $dictname method $method prebody $prebody
	dict set $dictname method $method body $body
   }


    proc class_variable_default {classname varname dvalue} {
	set dictname [object_dict $classname]
	if ![dict exists [set $dictname] variable $varname type] {
	    dict set $dictname variable $varname type symbol
	}
	if ![dict exists [set $dictname] variable $varname cscript] {
	    dict set $dictname variable $varname cscript {}
	}
	dict set $dictname variable $varname dvalue $dvalue
    }

    proc class_variable_create {classname varname type dvalue cscript} {
	set dictname [object_dict $classname]
	dict set $dictname variable $varname type $type
	dict set $dictname variable $varname dvalue $dvalue
	dict set $dictname variable $varname cscript $cscript
	dict set $dictname variable $varname defined $classname
    }

    proc class_inherit {classname isa} {
	set statevar [object_dict $classname]
	set state [set $statevar]
	set ancestors [dict get $state ancestors]

	set stack {}
	foreach c [lreverse $isa] {
	    set c [tao_normalize $c]
	    if { $c == $classname } continue
	    if ![::tao::class_exists $c] {
		error "Unknown class $c"
	    }
	    foreach item [::tao::class_ancestors $c] {
		if ![::tao::class_exists $item] {
		    error "Unknown class $item"
		}
		ladd ancestors $item
	    }
	    ladd ancestors $c
	}
	dict set $statevar ancestors $ancestors
	
	foreach item $ancestors {
	    if { $item == "tao.root" } continue
	    if { $item == $classname } continue
	    set adict [object_dict $item]

	    if [dict exists [set $adict] decendents] {
		set dlist [dict get [set $adict] decendents]
	    }
	    ladd dlist $classname
	    dict set $adict decendents $dlist
	}
        
	set ::tao::inherit_run 1
    }

    proc class_islist   {classname} { 
	set dictname [object_dict $classname]
	set result [dict get [set $dictname] ancestors]
	lappend result $classname
	return $result
    }
    proc class_ancestors   {classname} { 
	set dictname [object_dict $classname]
	return [dict get  [set $dictname]  ancestors]
    }

    proc class_decendents {classname} {
  	set dictname [object_dict $classname]
	return [dict get [set $dictname] decendents]
    }

    proc class_interpret {classname body} {
	cpush $classname
	set ::tao::inherit_run 0
	cpeek
	variable defaultstate
	variable buildscript
	set buildscript($classname) {}
	namespace eval ::tao::build $body
	if { $::tao::inherit_run == 0 } { 
	    class_inherit $classname tao.root
	}
	cpop
    }

  
    proc class_nspace class {
	set class [string trimleft $class :]
	set class [string trimleft $class .]
	return ::${class}
    }
  
    proc class_info {thisclass field} {
	return [dict get [set [object_dict $thisclass]] $field]
    }

    proc cpeek {} { 
	variable cstack
	variable thisclass 
	set thisclass [lindex $cstack 0]
	namespace eval [class_nspace $thisclass] {}
	uplevel 1 [list set thisclass ${thisclass}]   
    }
    
    proc cpush classname { 
	variable cstack
	if ![info exists cstack] { set cstack {} }
	set cstack [linsert $cstack 0 $classname]
	namespace eval $classname {}
    }
    
    proc cpop {} { 
	variable cstack
	set class [lindex $cstack 0]
	set cstack [lrange $cstack 1 end]
	return $class
    }
    
    proc body {methodname arglist body} { 
	set idx [string last :: $methodname]
	set class [string range $methodname 0 [expr $idx - 1]]
	set method [string range $methodname [expr $idx + 2] end]
	cpush $class
	namespace eval ::tao::build [list method $method $arglist $body]
	cpop
	#compile_methods $class
    }

    proc class_reset {classname {filename {}}} {
	set nspace [class_nspace $classname]
      
	namespace eval $nspace {
	    namespace forget *
	}
	###
	#  Add one built in class
	###
	set cdict [object_dict $classname]
	foreach {var val} {
	    method {}
	    variable {}
	    ancestors tao.root
	    decendents {}
	    compiled 0
	} {
	    dict set $cdict $var $val
	}
    }

   
    proc class_modify {classname body} { 
	::tao::handle_normalize classname

	class_interpret $classname $body

	set classlist  [class_decendents $classname]
	ladd classlist $classname
	foreach c $classlist {
	    if [class_compiled $c] {
		class_compiled $c 0
		compile_methods $c
	    }
	}
    }


    proc class {classname body} { 
	::tao::handle_normalize classname
        if { $classname != "tao.root" } {
	if [class_exists $classname] {
	    error "Class $classname already exists."
	}
        }
	variable library_file
	#set fname  [file normalize [info script]]
	dict set [object_dict $classname] filename $library_file

        class_reset $classname
	class_interpret $classname $body
    }

    proc genus {order class genera species classList} { 

	if { $species != "common" } { 
	    set definition \n [list inherit $order.$class.$genus.common]
	}
	if [dict exists $classList common] { 
	    append definition \n [dict get $classList common]
	}
	foreach genus $genera {
	    set thisdef $definition
	    if [dict exists $classList $genus] {
		append definition \n $thisdef
	    }
	    regsub -all %GENUS% $thisdef $order.$class.$genus thisdef
	    regsub -all %SPECIES% $thisdef $order.$class.$genus.$species thisdef

	    ::tao::class $order.$class.$genus.$species $thisdef
	}
    }

    proc class_compiled {class {newstate {}}} {
	if { $newstate == {} } {
	    return [dict get [set [object_dict $class]] compiled]
	}
	dict set [object_dict $class] compiled [string is true $newstate]
    }
   
    proc class_method_dict {classname {asobject 0}} { 
	###
	#  Build the sorts of stuff we need
	###
	set method_dict {}
	set methodlist {}

	set classlist [class_islist $classname]
	foreach c $classlist {
	    if ![class_exists $c] {
		error "Unknown class $c, inherited by $classname"
	    }
	}

	array set mdefined {}
	array set marglist {}
	array set mtype    {}
	array set mprebody {}
	array set mbody    {}

	foreach aclass $classlist {
	    set adict [object_dict $aclass]
	    set adictval [set $adict]
	    dict for {m data} [dict get $adictval method] {
		ladd    methodlist  $m
		lappend mdefined($m) $aclass
		dict with $adict method $m {
		    lappend mtype($m)    $type
		    lappend marglist($m) $arglist
		    lappend mprebody($m) $prebody
		    lappend mbody($m) $body
		}
	    }
	}

	foreach meth $methodlist { 

	    set ldefined  $mdefined($meth)
	    set ltype     $mtype($meth)
	    set larglist  $marglist($meth)
	    set lprebody  $mprebody($meth)
	    set lbody  $mbody($meth)


	    set d [lindex $ldefined end]

	    set prebodl {}
	    set rawbodl {}
	    set arglist [lindex $larglist end]

	    set idx -1
	   
	    foreach type $ltype { 
		incr idx
		if { [lsearch {{} proc method} $type] >= 0}  {
		    set prebodl {}
		    set rawbodl {}
		}
		lappend prebodl [lindex $lprebody $idx]
		lappend rawbodl [lindex $lbody $idx]
	    }
	    set type [lindex $ltype end]

	    set body {}

	    dict set method_dict $meth type $type

	    if { $type == "proc" } { 
		dict set method_dict $meth arglist $arglist
		set body {}
	
		append body \n [lindex $rawbodl end]
		dict set method_dict $meth body $body
		continue
	    }
	   
	    switch $type {
		chain -
		mesh {
		    if { $type == "chain" } { 
			append body \n {set result {}}
		    }
		    append body \n "### PREBODY"
		    set idx -1
		    foreach b $prebodl {
			incr idx
			if { [string trim $b] != {} } { 
			    append body \n "### FROM [lindex $ldefined $idx]"
			    append body \n $b
			}
		    }
		    append body \n "### MAINBODY"
		    set idx -1
		    foreach b $rawbodl {
			incr idx
			if { [string trim $b] != {} } { 
			    append body \n "### FROM [lindex $ldefined $idx]"
			    append body \n $b
			}
		    }
		    if { $type == "chain" } { 
			append body \n {return $result}
		    }
		}
		default {
		    append body \n "### Method Script"
		    append body \n [lindex $rawbodl end]
		}
	    }
	    if { $type == "chain" } { 
		append body \n "return \$result" \n
	    }
	    dict set method_dict $meth arglist $arglist
	    dict set method_dict $meth body $body
	}
        return $method_dict
    }

    proc compile_methods {classname {asobject 0}} { 
	if [class_compiled $classname] return

	set dictname [object_dict $classname]
	set nspace   [class_nspace $classname]
	set method_dict [class_method_dict $classname $asobject]

	dict for {mname minfo} $method_dict { 
	    set mbody {}
	    dict with minfo {
		set procbody {}

		if { $type != "proc" } { 
		    append procbody \n [list set thismethod $mname]
		    append procbody \n [list set thisclass $classname]
		    if $asobject {
			append procbody \n [list ::tao::opoke $classname]
			append procbody \n [list set this $classname]
			append procbody \n [list set statevar [::tao::object_dict $classname]] \n
		    } else {
			append procbody \n {set this [::tao::opeek]}
			append procbody \n {set statevar [::tao::object_dict $this]} \n
		    }
		    append procbody \n {::tao::object_update $statevar } \n
		    append procbody \n {dict with $statevar state } "\{\n"
		} elseif $asobject {
		    append procbody \n [list ::tao::opoke $classname]
		}

		append procbody \n $body

		if { $type != "proc" } { 
		    append procbody "\n" "\}" "\n"
		}
		namespace eval $nspace [list ::proc $mname $arglist $procbody]
	    }
	}
	
	###
	#   Burn in all of the variables and defaults 
	#   for new objects of this class
	###
	set newstate {variable {} state {} nv_state {}}

	foreach c [class_islist $classname] {
	    set aclassvar [object_dict $c]
	    dict for {varname info} [dict get [set $aclassvar] variable] {
		dict for {field value} $info {
		    dict set newstate variable $varname $field $value
		}
	    }
	}
	dict for {varname info} [dict get $newstate variable] {
	    if ![dict exists $newstate state $varname] {
		dict set newstate state $varname [dict get $info dvalue]
	    }
	    if { [dict get $info type] == "static" } { 
		if ![dict exists $newstate nv_state $varname] {
		    dict set newstate nv_state $varname [dict get $info dvalue]
		}
	    }
	}
	set ${nspace}::defaultObject $newstate

	class_compiled $classname 1

	###
	#  Build the sorts of stuff we need
	###
    }

    proc library_path {handle basepath {subdirectories {}}} {
	#::tao::cacheidx_init $handle $basepath
	set plist {}
	if { $subdirectories == {} } { 
	    lappend plist $basepath
	} else {
	    foreach path $subdirectories {
                lappend plist [file join $basepath $path]
            } 	    
	}
        foreach fpath $plist {
	    if [file exists [file join $fpath baseclass.tcl]] { 
		::tao::libsource [file join $fpath baseclass.tcl]
            }
            foreach file [glob -nocomplain [file join $fpath *.tcl]] {
                if {[lsearch {pkgIndex.tcl baseclass.tcl} [file tail $file]] < 0 } { 
                    ::tao::libsource $file
                }
            }
        }
    }

    proc libsource {fname} {
	variable library_file

	set library_file [file normalize $fname]
	source $library_file
	set library_file {}
    }
}