#! /bin/env tclsh

package require {ycl proc}
[yclprefix] proc alias alias [yclprefix] proc alias
[yclprefix] proc alias aliases [yclprefix] proc aliases
package require {ycl ns join}
alias join [yclprefix] ns join
aliases {
	{ycl eval} {
		upcall
	}
}

package require {ycl flow depends}
interp alias {} [namespace current]::dlet {} [yclprefix] flow let
interp alias {} [namespace current]::depends {} [yclprefix] flow depends

variable [join doc $] {
	description {
		In a future version of Tcl where is a list

			an empty string at the beginning of the list will indicate
			resolution from the global namespace

			if the first item is itself list it is auto-expanded and the name
			is resolved relative to the caller's namespace

				for example, a variable named the empty string would look like this

					{{}}
	}
}


proc $ args {
	lassign $args first
	if {[string is list $first] && [llength $first]} {
		set args [lreplace $args 0 0 {*}$first]
		set args [join {*}$args[set args {}]]
		uplevel 1 [list ::set $args]
	} else {
		set args [join {*}$args[set args {}]]
		set $args
	}
}


proc constant varname {
	upvar $varname var

	# read now so as not to set off the trace later
	set value $var
	uplevel 1 [list ::trace add variable $varname write [list ::apply [list {value var1 var2 ops} {
		error [list {read-only variable} $var1]
	} [namespace current]] $value]]
}


namespace ensemble create -command is -map {
	upvar {{is upvar}}
}


proc {is upvar} name {
	expr {![catch {
		upcall 1 upvar 0 $name $name
	}]}
}


variable doc::let {
	description {
		updates the value of a variable when the variable is read and the value
		of one of the variables it depends on has changed

		arguments

			varname
			
				description

					the name of the variable to manage

			last argument

				the body of a routine that returns a new value for the variable

			second through second-to-last arguments

				each argument is a list of

					the name of a variable that the tracked variable depends on

					optional

						a name to give the value of variable in the routine
						that updates the managed variable
							the empty string indicates that the variable value
							should not be passed to the routine

						if the named variable is a local variable

							the managed variable is unset when the named
							variable is unset
	}
}
proc let {varname args} {
	variable let
	variable namespace
	set id [list [info cmdcount]]
	lassign [uplevel 1 [list [namespace which dlet] [
		list $namespace tail] $args]] spec body info

	set letget [namespace which let_get]
	foreach {alias target} $spec[set spec {}] {
		lassign [uplevel 1 [list $letget $target]] fulltarget getcmd
		lappend spec $alias $getcmd 
		dict set info $alias target $fulltarget
		dict set info $alias get $getcmd
	}
	dict set let $id $info

	foreach {key val} $info {

		uplevel 1 [list trace add variable $target unset [
			list [namespace which apply] [list {varname name1 name2 op} {

			uplevel 1 [list [namespace which unset] $varname]
		}] $varname]]
	}

	set ns [uplevel 1 $namespace current]

	set routine [list [namespace which let_make] $id $ns $spec $body]
	uplevel 1 [list [namespace which trace] add variable $varname read $routine]
	uplevel 1 [list [namespace which trace] add variable $varname unset [list [
		namespace which letdelete] $id]]
	return $id
}


proc let_arrayget {name1 name2} {
	set array [uplevel 1 [
		list [namespace which array] get $name1]]
	if {[dict size $array] == 0} {
		if {[uplevel 1 [list [
			namespace which namespace ] which -variable $name1]] eq {}} {
			# [array get] doesn't return an error of the variabel
			# doesn't exist
			#     so do it here
			error [list {no such variable} $name1]
		}
	}
	dict get $array $name2
}


proc let_get target {
	variable namespace_current
	set arrayvar 0

	switch [llength $target] {
		1 {
			if {[regexp {^([^(]+)\((.*)\)$} $target -> tname1 tname2]} {
				set arrayvar 1
			} else {
				set tname1 [lindex $target 0]
			}
		}
		2 {
			lassign $target tname1 tname2
			set arrayvar 1
		}
		default {
			error [list {target should be a list containing 1 or 2 items}]
		}
	}


	if {$tname1 in [uplevel 1 [namespace which info] locals]} {
		set level #[expr {[info level] - 1}]

		if {$arrayvar} {
			set getcmd [list [namespace which uplevel] $level [list [
					namespace which let_arrayget] $tname1 $tname2]]
		} else {
			set xvar [list [namespace which set] $tname1]
			set getcmd [list [namespace which uplevel] $level $xvar]
		}

		set fulltarget $target
	} else {
		if {[string match ::* $target]} {
			set fulltarget $target
		} else {
			set ns [uplevel 1 $namespace_current]
			set relns [namespace qualifiers $target]
			if {$ns eq {::}} {
				set fulltarget ::$target
			} else {
				set fulltarget ${ns}::$target
			}
			if {$relns eq {}} {
				set targetns $ns
			} else {
				set target [namespace tail $target[set target {}]]
				set targetns $ns::$relns
			}
		}

		if {$arrayvar} {
			set getcmd [list [namespace which let_arrayget] $tname1 $tname2]
		} else {
			set getcmd [list [namespace which set] $fulltarget]
		}
	}
	list $fulltarget $getcmd
}


proc let_make {id ns args cmd name1 name2 op} {
	lassign [depends $args [namespace current]::let $id] changed xargs xvals
	if {$changed} {
		upvar $name1 var
		set var [uplevel 1 [list [namespace which ::apply] [
			::list $xargs $cmd $ns] {*}$xvals]]
	}
}


proc let_target target {
}


proc letinfo unique {
	variable let
	set res {}
	if {[dict exists $let $unique]} {
		set res [dict get $let $unique]
	} else {
	}
	return $res
}


proc setmap {text script} {
	package require {ycl parse tcl}
	[yclprefix] proc alias [yclprefix]::parse::tcl::commands::commands
	proc setmap {text script} {
		set res {}
		foreach command [commands $script] {
			set command [lassign $command[set command {}] varname]
			upvar $varname var
			set var [string map $command $text]
		}
		return
	}
	tailcall setmap $text $script
}


variable namespace [namespace which namespace]
variable namespace_current [list [namespace which namespace] current]

variable let {}
