Artifact b6d813ee28521e798039e390b62c66e266ca540e:

• File packages/dict/lib/deep/main.tcl — part of check-in [1ac9fb76f9] at 2020-04-13 20:21:03 on branch trunk — exec new routine extern

  dict deep

  new routine

  dedent

  (user: pooryorick size: 3322)

#! /usr/bin/env tclsh


namespace eval utils {
	package require {ycl proc}
	[yclprefix] proc alias alias [yclprefix] proc alias
	alias aliases [yclprefix] proc aliases

	aliases {
		{ycl list deep}
		{ycl list} {
			lindex
			sl
			pop
			take
		}
		{ycl ns} {
			nsjoin join
		}
		{ycl proc} {
			optswitch
			stub
		}
		{ycl string} {
			sdedent dedent
		}
	}
	package require {ycl list deep}

	alias set_ [nsjoin {} set]
	alias dict_ [nsjoin {} dict]
}

namespace path utils


dict set doc routines dedent {
	description {{
		dedent the leaves in a deep dictionary
	}}
}
proc dedent dictname {
	upvar $dictname dict
	set_ new {}
	if {[is_deep dict]} {
		foreach {key val} $dict[set_ dict {}] {
			if {[is_deep val]} {
				dedent val
			} else {
				lindex val 0
				sdedent val
				set_ val [list $val[set_ val {}]]
			}
			lappend new $key $val
		}
	} else {
		if {[llength $val] > 1} {
			error [list {not deep} $val]
		}
		lindex val 0
		dedent val
	}
	set_ dict $new[set_ new {}]
	return
}


proc empty {dictname args} {
	upvar 1 $dictname dict
	set_ new [dict get $dict {*}$args]
	set_ len [llength $new]
	expr {$len == 0}
}


proc get {dictname args} {
	upvar $dictname dict
	set_ new [dict get $dict {*}$args]
	set_ len [llength $new]
	if {$len == 1} {
		lindex new 0
		set_ dict $new 
	} elseif {$len == 0} {
		error empty
	} else {
		set_ dict $new
	}
	return
}

namespace ensemble create -command is -map {
	deep is_deep
}

proc is_deep {dictname args} {
	upvar 1 $dictname dict
	if {[llength $args]} {
		pop args key
		set_ nested $dict
		get nested {*}$args
		# use the standard [dict] to get the last value
		set_ last [dict_ get $nested $key]
	} else {
		set_ last $dict
	}
	deep is deep last
}

variable doc::merge {
	description {
		merge a deep dictionaries
	}
}
proc merge {dictname args} {
	upvar $dictname dict
	foreach arg $args {
		upvar $arg dict2
		# [foreach] retains duplicate keys
		dict size $dict2
		foreach {key val2} $dict2[set_ dict2 {}] {
			if {[dict exists $dict $key]} {
				set_ val1 [dict get $dict $key]
				if {[llength $val1] != 1} {
					if {[llength $val2] > 1} {
						set_ val [dict get $dict $key]
						dict set dict $key {}
						merge val val2
						set_ val2 $val
						dict set dict $key $val2
						continue
					}
				}

			}
			lappend dict $key $val2
		}
	}
	return
}


proc pretty {dictname args} {
	set_ indent {    }
	set_ level 0
	while {[llength $args]} {
		take args opt
		optswitch $opt {
			indent - level {
				take args val
				set_ $opt $val
			}
		}
	}
	upvar 1 $dictname dict
	set_ started 0
	set_ indent1 [string repeat $indent $level]
	foreach {key val} $dict[set_ dict {}] {
		if {$started} {
			append dict \n
		} else {
			set_ started 1
		}
		append dict "$indent1[list $key] "
		if {[llength $val] == 1} {
			append dict [list [list [::lindex $val 0]]]
		} else {
			pretty val indent $indent level [expr {$level + 1}]
			if {[string length $val]} {
				append dict "\{\n"
				append dict $val
				append dict "\n$indent1\}"
			} else {
				append dict "{}"
			}
		}
	}
	return
}


proc set {dictname args} {
	upvar 1 $dictname dict
	set_ end $args
	lindex end end
	set_ res [dict set dict {*}[lrange $args 0 end-1] [
		list $end]]
	lindex res end
	if {[string is list -strict $res] && [llength $res] == 1} {
		lindex res end
	}
	return $res
}