#! /bin/env tclsh

[yclprefix] proc alias alias [yclprefix] proc alias
alias aliases [yclprefix] proc aliases

aliases {
	{ycl list} {
		take
	}
	{ycl eval} {
		upcall
	}
	{ycl ns} {
		absolute?
		nsjoin join
		object
		unique
		which
	}
	{ycl proc} {
		checkargs
	}
}

#warning:  any specified instance variables get linked to the variable by the
#same name in the instance namespace.  Therefore, higher shelfs won't be
#searched for their value. 
proc asmethod {spec {selfvar _}} {
	lassign $spec[set spec {}] pargs objvars nsvars body
	set pargs [linsert $pargs[set pargs {}] 0 $selfvar]
	set script {}
	foreach varname $nsvars {
		append script [list variable $varname]\n
	}
	foreach varname $objvars {
		if {[llength $varname] == 2} {
			lassign $varname[set varname {}] othername localname
		} else {
			lassign $varname[set varname {}] othername localname
			set localname $othername
		}
		append script [string map [
			list {{{selfvar}}} [list $selfvar] {{{localname}}} [
				list $localname] {{{othername}}} [list $othername]] {
			namespace upvar [
				[set {{selfvar}}] .namespace] {{othername}} {{localname}}
		}]
	}
	return [list $pargs $script\n$body]
}

proc configure_template {} {
	return {
		set doc [@doc@]
		set internal 0
		if {[llength $args] == 1} {
			set name [lindex $args 0] 
			if {[dict exists $doc args $name]} {
				if {[dict exists $doc args $name name]} {
					set name [dict get $doc args $name name]
				}
				return [@get@]
			}
			return -code error [list {} {unknown configuration item} $name]
		} elseif {[llength $args] > 1} {
			if {[llength $args] % 2} {
				if {[lindex $args 0] eq {!}} {
					set internal 1 
					set args [lrange $args[set args {}] 1 end]
				} else {
					error "wrong # arguments.  Should be <name> <value> ..."
				}
			}
			set res {}
			foreach {name value} [apply [list {_ args} {
				@checkargs@ [uplevel 1 {set doc}] {*}$args
				apply {locals {
					# The purpose of this proc is to have a safe place to set a
					# variable named x
					concat {*}[lmap x $locals {
						if {$x in {_ args}} {
							continue
						}
						list $x [uplevel 1 [list set $x]]}]
				}} [info locals]
			} [namespace current]] @self@ {*}$args] {
				if {!$internal && [dict exists $doc args $name automatic]
					&& [dict get $doc args $name automatic]} {
					return -code error [
						list {attempt to configure automatic setting} $name]
				}
				dict set res $name [@set@]
			}
			if {[dict size $res] == 1} {
				set res [lindex [dict values $res[set res {}]] end]
			}
			return $res
		} else {
			set res {}
			foreach arg [dict keys [dict get $doc args]] {
				if {[dict exists $doc args $arg name]} {
					set name [dict get $doc args $arg name]
				} else {
					set name $arg
				}
				if {[@exists@]} {
					dict set res $arg [@get@]
				}
			}
			return $res
		}
	}
}

proc doplugin {_ shelf target args} {
	::tailcall $shelf {*}$target $_ [$_ .site] {*}$args 
}


apply [list {} {
	set template {
		if {![string match ::* $shelf]} {
			set shelf_orig $shelf
			set shelf [uplevel 1 [list namespace which $shelf[set shelf {}]]]
			if {$shelf eq {}} {
				error [list {shelf does not exist} $shelf_orig]
			}
		}
		if {![llength $args]} {
			if {[$shelf .state exists plugins]} {
				set args [$shelf .state get plugins]
			}
		}
		set name [{*}$base .spawn [info cmdcount]]

		@plug@

		foreach method $args {
			lassign $method mname target
			if {[llength $method] == 1} {
				set target $mname
				set mname [lindex $target 0]
			} elseif {[llength $method] == 2} {
			} elseif {[llength $method] == 0} {
				error [list {wrong # args}]
			}
			$name .method $mname [list [namespace which doplugin]] [list $shelf $target]
		}
		trace add command [$_ _] delete [list rename $name {}]
		$_ . .inject $name
		return $name 
	}

	proc .nsshelf_plug {_ base shelf args} [string map [list @plug@ {
		$name .state set plugged $shelf
	}] $template]

	proc .tcloo_plug {_ base shelf args} [string map [list @plug@ {
		# This is a little tricky.  $name acts as an instantiated object when
		# called directly, but also acts as a superclass of $_.
		# Requires a pyk-TclOO 
		oo::objdefine $name class $shelf
	}] $template]

} [namespace current]]


proc .new args  {
	variable shelfns
	if {[llength $args]} {
		take args name
		set ns $name
	} else {
		set ns [nsjoin [namespace current] objects [info cmdcount]]
		set name $ns
	}
	set object [upcall 1 object $name]
	$object .nscall namespace eval doc {}
	set adminns [$object .adminns]
	set [nsjoin $adminns up] {}
	.state::.new $object
	$object .extend $shelfns
	$object .setup
	return $object
}


namespace eval .state {}
alias [nsjoin .state nsjoin] nsjoin

namespace eval .state {

	proc dodict {_ op args} {
		set ensemble [nsjoin [$_ .namespace] .state .state]
		set map [namespace ensemble configure $ensemble -map]
		dict update map .state state {
			set info [lindex $state 1]
			dict $op info {*}$args
			set state [lreplace $state[set state {}] 1 1 $info]
		}
		namespace ensemble configure $ensemble -map $map
		get $_ {*}[lrange $args 0 end-1]
	}


	proc .new _  {
		set ns [namespace eval [nsjoin [$_ .namespace] .state] {
			namespace current
		}]
		set routine [nsjoin $ns .state]
		namespace ensemble create -command $routine  \
			-parameters _\
			-map {lappend .lappend lreplace .lreplace set .set .state {dummy1 {}}} \
			-subcommands {
				exists
				get
				lappend
				lreplace
				set
			}
		$_ .extend $ns
	}

	proc .set {_ args} {
		dodict $_ set {*}$args
	}


	proc exists {_ args} {
		set ensemble [nsjoin [$_ .namespace] .state .state]
		set map [namespace ensemble configure $ensemble -map]
		set state [dict get $map .state]
		set info [lindex $state 1]
		return [dict exists $info {*}$args]
	}


	proc get {_ args}  {
		set ensemble [nsjoin [$_ .namespace] .state .state]
		set map [namespace ensemble configure $ensemble -map]
		set state [dict get $map .state]
		set info [lindex $state 1]
		if {[llength $args]} {
			return [dict get $info {*}$args]
		} else {
			return $info
		}
	}


	proc .lappend {_ path args}  {
		set ensemble [nsjoin [$_ .namespace] .state .state]
		set map [namespace ensemble configure $ensemble -map]
		dict update map .state state {
			set info [lindex $state 1]
			set list [dict get $info {*}$path]
			if {[llength $args]} {
				::lappend list {*}$args
				dict set info {*}$path $list
				set state [lreplace $state[set state {}] 1 1 $info]
			}
		}
		namespace ensemble configure $namespace -map $map
		return $list
	}


	proc .lreplace {_ path args}  {
		set ensemble [nsjoin [$_ .namespace] .state .state]
		set map [namespace ensemble configure $ensemble -map]
		dict update map .state state {
			set info [lindex $state 1]
			set list [dict get $info {*}$path]
			if {[llength $args]} {
				set list [::lreplace list[set list {}] {*}$args]
				dict set info {*}$path $list
				set state [lreplace $state[set state {}] 1 1 $info]
			}
		}
		namespace ensemble configure $namespace -map $map
		return $list
	}

	proc replace {_ value} {
		set ensemble [nsjoin [$_ .namespace] .state]
		set map [namespace ensemble configure $ensemble -map]
		dict update map .state state {
			set state [lreplace $state[set state {}] 1 1 $value]
		}
		namespace ensemble configure $ensemble -map $map
		return $value
	}


	proc unset {_ args} {
		dodict $_ unset {*}$args
	}

}


#proc .vars {_ args} {
#	set vars {}
#	set ns [$_ .namespace]
#	foreach var $args {
#		if {![string is list $var]} {
#			set var [list $var]
#		}
#		if {[llength $var] == 1} {
#			lappend vars [lindex $var 0] [lindex $var 0]
#		} else {
#			lappend vars {*}$var 
#		}
#		uplevel 1 [list namespace upvar $ns {*}$vars]
#	}
#	return
#}

namespace eval objects {}

variable shelfns [nsjoin [namespace parent] shelf]

namespace export *
