#! /bin/env tclsh

package require ycl::proc
namespace import [yclprefix]::proc::checkargs
namespace import [yclprefix]::proc::checkspec
namespace import [yclprefix]::proc::upmethod
package require ycl::var::upmethods
interp alias {} [namespace current]::copyproc {} [yclprefix]::proc::copy
variable proc [yclprefix]::proc

package require ycl::var
namespace import [yclprefix]::var::$

namespace eval doc {}

variable UNIQUE_IN #

namespace eval niladate {}
variable doc::niladate {
	description {
		enable calling a namespace ensemble with no args
	}
	args {
		cmd {
			description {
				the namespace ensemble command to adjust
			} 
		}
		move {
			description {
				where to move the current namespace ensemble command
			}
			default {
				set move niladate::[uplevel [list namespace which $cmd]] 
			}
		}
		target {
			description {
				the command to execute when the namespace is invoked without arguments
			}
		}
	}
}
proc niladate args {
	checkargs doc::niladate
	uplevel [list rename $cmd $move]
	set body {
		if {![llength $args]} {
			return [$target]
		} else {
			return [$move {*}$args]
		}
	}
	set body [string map [list \$target [uplevel [list namespace code $target]] \
		\$move [list $move]] $body]
	uplevel [list proc $cmd args $body]
}

proc copyvars {from to} {
	foreach var [info vars ${from}::*] {
		set newname [namespace tail $var]
		if {[array exists $var ]} {
			namespace eval $to [list array set $newname [array get $var]] 
		} else {
			namespace eval $to [list variable $newname [set $var]]
		}
	}
}

#value: name of new ensemble
proc ensemble {callingspace {id {}} } {
	if {$id eq {}} {
		set id [unique prefix $callingspace]
	} else {
		set id [normalize $id $callingspace]
	}

	if {[namespace exists $id]} {
		rename $id {}
		#return -code error "namespace already exists: $id"
	}

	namespace eval $id namespace ensemble create
	return $id
}

if 0 {
	args:
		id
			the namespace to operate on
		subcommand
			name of the new subcommand
		args
			the command prefix assigned to subcommand
	value

		modified map for $id

	description

		as a convenience, if args are not supplied, the calling environment is
		searched for a proc having the same name as subcommand
}
proc map {id subcommand args} {
	if {![llength $args]} {
		set args [list $subcommand]
	}
	set target [lindex $args 0]
	set target [uplevel [list [namespace current]::normalize $target \
		[uplevel namespace current]]]
	if [string equal $target {}] {
		return -code error "no such target: $target"
	}
	set args [lreplace $args[unset args] 0 0 $target]
	set map [namespace ensemble configure $id -map]
	dict set map $subcommand $args
	namespace ensemble configure $id -map $map
	return $map
}

proc normalize {name args} {
	if {[llength $args] > 1} {
		return -code error "wrong #args: should be \[normalize name ?namespace?]"
	}
	switch -glob $name {
		{} {
			return ::
		}
		::* {
			return $name
		} default {
			if {[llength $args] == 0} {
				set namespace [uplevel namespace current]
			} else {
				set namespace [lindex $args 0]
			}
			if {$namespace ne {} && ![string match *:: $namespace]} {
				append namespace ::
			}
			append namespace $name
			return $namespace
		}
	}
}

variable doc::die {
	description {
		how to die
	}
}

upmethod die {cmd} {} {} {
	trace add command $_ delete [list apply [list {cmd args} {
		lassign $args name
		#this catch is a hack
		#todo: fix trace so that trace errors don't disappear 
		if {[catch {
			if {$cmd ne {}} {
				$name {*}$cmd 
			}
			#the namespace may already be deleted, causing this command to be
			#deleted
			catch {namespace delete $name}
			if {[info exists $name]} {
				rename $name {}
			}

		} eres eopts]} {
			puts stderr [dict get $eopts -errorinfo]
			puts stderr [dict get $eopts -errorstack]
			#this currently gets swallowed by Tcl trace machinery
			return -options $eopts $eres
		}
	} $_] $cmd]
}

variable doc::object {
	description {
		create a new object, i.e., a namespace with behaviours described below.

		Calling [namespace ensemble create] in an already existing object will
		cause that object to be deleted.  Don't do that if you don't want to do
		that. 

	}
	args {
		name {
			description {
				name of the new object, i.e., the ns that underlies the object.
				It will be created as namespace ensemble
			}
			process {
				if {$name eq {}} {
					set name [lindex [
						{{unique}} prefix [namespace current]]]
				}
				{{normalize}} $name [uplevel namespace current]
			}
		}
		cmd {
			description {
				a list of a command to represent the object, and any extra
				arguments (often a particular subcommand) to pass to ${ns} when
				the alias is invoked.

				This cmd will be deleted when the object is deleted, and vice
				versa.

			}
			default {}
		}
		import {
			description {
				commands to import
			}
			default {lindex {}}
		}
		export {
			description {
				names of commands to export in this namespace.  Like [namespace
				export], except that the argument is a list of names instead of
				patterns, and before being exported, each name is resolved in
				the scope of the caller of this proc, exported from its actual
				namespace, and imported.
				
				Subcommands can figure out which namespace they are a
				subcommand of by inspecting the first argument of [info level
				0].  ycl::proc::method is provided as a convenience procedure
				for creating commands that act like "methods", i.e., that are
				aware of $ns and use it to store state and call sibling
				subcommands.

				there is also ycl::proc::upmethod, which only works when the
				command is *not* exported
			}
			default {lindex {}}
		}
		die {
			description {
				how to die.  Name of a command to invoke to die, i.e., when the
				namespace is deleted
			}
			default {}
		}
	}
}
dict set doc::object args name process [string map [
	list {{{normalize}}} [list [namespace current]::normalize] \
        {{{unique}}} [list [namespace current]::unique]
	] [dict get $doc::object args name process]]
proc object {{name {}} args} {
	if {[llength $args] % 2} {
		set args [linsert $args 0 0 $name]
		set name {}
	}
	checkargs doc::object
	#weird things can happen if a proc that already exists gets deleted by
	#[namespace ensemble create], like deleting the namespace creating
	#the ensemble, so preemptively remove any exising proc
	if {[namespace which $name] eq $name} {
		rename $name {}
	}
	namespace eval $name {
		namespace eval doc {}

		#upmethods only work when not exported, so let the user 
		#decide what to export
		#namespace export {[a-z]*}
		namespace ensemble create -prefixes off
	}
	layer $name
	set traceargs {} 
	if {[info exists cmd]} {
		lassign $cmd cmd targs
		interp alias {} $cmd {} $name {*}$targs 
		lappend  traceargs cmd $cmd
		trace add command $cmd delete [list apply [list {name args} {
			namespace delete $name 
		}] $name]
	}
	foreach export $export {
		set exportpath [uplevel [list namespace which $export]]
		if {$exportpath eq {}} {
			return -code error -errorcode [list [namespace current] [
				lindex [info level 0] 0] export unknown $export] \
				"[lindex [info level 0] 0]:  can not find export: $export"
		}
		set exportns [namespace qualifiers $exportpath]
		if {$exportns eq {}} {
			set exportns ::
		}
		namespace eval $exportns [
			list namespace export [namespace tail $exportpath]]
		namespace eval $name [list namespace import $exportpath]
		namespace eval $name [list namespace export $export]
	}
	foreach import $import {
		set importpath [uplevel [list namespace which $import]]
		if {$importpath eq {}} {
			return -code error -errorcode [list [namespace current] \
				[lindex [info level 0] 0] import unknown $import] \
				"[lindex [info level 0] 0]:  can not find import: $import"
		}
		$name import $importpath
	}
	if {[info exists die]} {
		set die [uplevel [list [namespace current]::normalize $die]]
	} else {
		set die {}
	}
	$name die $die
	return $name
}

variable doc::layer {
	description {
		adds the magic that makes upmethods work:  an -unknown entry to the
		ensemble evaluates the command in the namespace, thus giving upmethod a
		way to find the current object:  [uplevel 1 namespace current].

		This also "magically" provides commands like [$ns eval] using the
		standard ::eval
	}
}

proc layer {ns} {
	namespace ensemble configure $ns -unknown [list apply [list {args} {
		list apply [list args {
			uplevel [list namespace eval [namespace current] $args]
		} [namespace current]] [lindex $args 1]
	} $ns]]
	namespace eval $ns [list namespace path [list [namespace current]::. {*}[namespace eval $ns namespace path]]]
}

variable doc::parent {
	description {
		adds parent (and its parents) to the path of the current object, but
		does not import the parent's exported commands.  This design allows
		upmethods of the parents to be called on the current object.
	}
}
upmethod parent {args} {} {} {
	#uplevel 2 because uplevel 1 is the current object 
	foreach parent $args {
		set parent [uplevel 2 [list [namespace current]::normalize $parent]]
		lappend path $parent
		set paths [namespace eval $parent namespace path] 
		while {[llength $paths]} {
			set path1 {}
			set paths [lassign $paths path1]
			foreach path2 [namespace eval $path1 namespace path] {
				if {$path2 ne $path1} {
					lappend paths $path2
				}
			}
			if {$path1 ni $path} {
				lappend path $path1
			}
		}
	}
	foreach path1 [namespace eval $_ namespace path] {
		if {$path1 ni $path} {
			lappend path $path1
		}
	}
	namespace eval $_ [list namespace path $path]
}

upmethod unparent {parent} {} {} {
	parentc
}

variable doc::type {
	description {
		adds parent to the path of the current object, and also imports
		currently-exported commands of the object.  This design allows methods
		(not upmethods) of parents to be called on the current object.
	}
}
upmethod type {parent} {} {} {
	#uplevel 2 because uplevel 1 is the current object 
	set parent [uplevel 2 [list [namespace current]::normalize $parent]]
	namespace eval $_ [list namespace path [
		list $parent {*}[namespace eval $_ namespace path]]] 
	foreach pattern [namespace eval $parent namespace export]  {
		if {[namespace which ${_}::$pattern] eq {}} {
			catch {
				namespace eval $_ [list namespace import ${parent}::$pattern]
			}
			namespace eval $_ [list namespace export $pattern]
		}
	}
}

upmethod import args {} {} {
	foreach cmd $args {
		set target [uplevel 2 [list namespace which $cmd]]
		set tail [namespace tail $target]
		set targetns [namespace qualifiers $target]
		if {$targetns eq {}} {
			return -code error -errorcode [list [namespace current] [
				lindex [info level 0] 0] target notfound $target] \
				"can't find command: $cmd"
		}
		namespace eval $targetns [list namespace export $tail]
		if {[namespace which ${_}::$tail] ne {}} {
			rename ${_}::$tail {}
		}
		uplevel [list namespace eval $_ [list namespace import $target]]
		#objects should export nothing so that [namespace enemble configure -unknown]
		#can make sure the uplevel for all subcommands is the namespace
		#uplevel [list namespace eval $ns [list namespace export [namespace tail $target]]]
	}
}

#SYNOPSIS
#	upcmd ARGS	
#DESCRIPTION
#	Creates a new  namespace ensemble in the caller's parent namespace.  The new
#	command has the same name as the tail of the caller's namespace.  The target command prefix
#	is set by ARGS
proc upcmd {args} {
	set parent [uplevel namespace parent]
	set name [uplevel namespace current]
	if {[llength $args]} {
		set args [lassign $args target]
	} else {
		set target $name
	}
	set target [normalize $target $name]
	set name [namespace tail $name] 
	uplevel [namespace current]::map $parent $name $target {*}$args
}

#copy all procs from namespace $from to namespace $to
proc copyprocs {from to} {
	foreach proc [info proc ${from}::*] {
		copyproc $proc ${to}::[namespace tail $proc]
	}
}

variable doc::unique {
	description {
		generate unique namespace names

		incremements ${prefix}::${in}::$Id
	}
	args {
		prefix {
			description {
				namespace prefix for $in
			}
			default {
				set prefix {}
			}
		}
		in {
			description {
				namespace relative to prefix to create the unique namespace in
			}
			default {
				set in {}
			}
		}
	}
	value {
		a namespace which currently doesn't exist, and which this function will never return again
	}
}
proc unique args {
	variable UNIQUE_IN
	variable Id
	checkargs doc::unique
	if {$prefix eq {}} {
		set prefix [namespace current]
	}
	if {$in eq {}} {
		set in $UNIQUE_IN
	}
	set id ${prefix}::${in}::[incr Id]
}


#this is the "toplevel" object.  Bootstrap it
namespace eval . {
	foreach upmethod {die import method parent type upmethod checkargs checkspec} {
		namespace import [namespace parent]::$upmethod
	}
	namespace import [yclprefix]::var::upmethods::$
	namespace import [yclprefix]::var::upmethods::$?
	#can't export because that would mess upmethod up
	#namespace export * 
}
object . 
#[object] adds [namespace current]::. to the path of an object
namespace eval . [list namespace path {}]


