ycl

Artifact [1d71b7b181]
Login

Artifact 1d71b7b1818b1e6ee89a96f2c625b4e56161cddf:


#! /bin/env tclsh

package require fileutil

package require {ycl proc}
[yclprefix] proc alias [yclprefix]::proc::alias
[yclprefix] proc alias aliases [yclprefix] proc aliases

package require {ycl ns ensemble}

aliases {
	{ycl list} {
		sl
	}
	{ycl knit} {
		auto
		knar
		knit
		knead
		knot
	}
	{ycl ns} {
		ensemble
	}
}
#package require {ycl test data}
package require {ycl test}
[yclprefix]::test::init

namespace import [yclprefix]
if {[yclprefix] ne {::ycl}} {
	rename [namespace tail [yclprefix]] ycl
}

proc suite_main {} {
	set setup1 {
        set res {}
	}
	set cleanup1 {
		catch {set res {}}
		apply {{} {
			foreach name {p1 p2} {
				catch rename $name {}
			}
		}}
	}

	# knit utilized knar, so test knar, first.

	test knar {} -setup $setup1 -body {
		knit p1 {} {
			[` defdo n1 {} {
				lappend res 1 
			}]
			[` do n1]
		}
		p1

		knit p1 {} {
			[` def n1 {} {
				lappend res 2 
			}]
			[` do n1]
			[` do n1]
		}
		p1
		set res
	} -cleanup $cleanup1 -result [sl {
		1 1 2 2
	}]

	# Todo: these test results are sensitive to whitespace.  Find a more 
	# robust way to compare the results 
	test knar_nospace {} -setup $setup1 -body {
		lappend res {*}[knar {
			[`foreach x {a b} {
				lappend res x
			}]
		}]
		set res
	} -cleanup $cleanup1 -result [sl {
		# What's tested is the missing whitespace after [`
		{} {
			[`foreach x {a b} {
				lappend res x
			}]
		}
	}]

	test knar_var {} -setup $setup1 -body {
		knit p1 {} {
			set num1 val1 
			set num2 4
			set var0 val0 
		} {
			[` defdo n1 {var1 var2} {
				#test that bareword literals in expr's are safe
				lappend res [expr {${var1}}]
				lappend res ${var1} 
				lappend res #{var2} 
			} $num1 {5 7}][` script {incr num2}]
			[` do n1 $num1 $num2] 
			[` auto {lappend res ${var0}}]
		}
		p1
		set res
	} -cleanup $cleanup1 -result [sl {
		val1 val1 5 7 val1 val1 5 val0
	}]

	test knar_recursive {} -setup $setup1 -body {
		knit p1 {} {
			[` defdo n1 {} {
				lappend res 1
			}]
			[` defdo n2 {} {
				lappend res 2
				[` do n1]
			}]
		}
		p1
	} -cleanup $cleanup1 -result [sl {
		1 2 1
	}]

	test knar_ensemble_duplicate {} -setup $setup1 -body {
		ensemble duplicate [yclprefix]::knit ns1
		set namespace [namespace ensemble configure ns1 -namespace]::cmds
		namespace eval ns1::cmds {
			proc macro1 cmdargs {
				lindex {lappend res 13}
			}
		}
		ns1 knit p1 {} {
			[` macro1]
		}
		p1
		set res
	} -cleanup $cleanup1 -result 13 

	knit empty {} {
	}

    knit double x {expr {${x} * 2}}

    knit exp2 x {::tcl::mathop::* ${x} ${x}}

    knit clear arg1 {unset ${arg1}}

    knit first list {lindex ${list} 0}

    knit rest list {lrange ${list} 1 end}

    knit last list {lindex ${list} end}

    knit drop list {lrange ${list} 0 end-1}

    knit greeting? x {expr {${x} in {hello hi}}}

    knit charcount {x {char { }}} {
        regexp -all ***=${char} ${x}
    }

    knit K {x y} {
        first [list ${x} ${y}]
    }

    knit yank varname {
        K [set ${varname}] [set ${varname} {}] 
    }

    knit lremove {varname idx} {
        set ${varname} [lreplace [yank ${varname}] ${idx} ${idx}]
    }

    knit lpop listname {
        K [lindex [set ${listname}] end] [lremove ${listname} end] 
    }

    knit lpop2 listname {
        K [lindex !{listname} end] [lremove ${listname} end] 
    }

    foreach cmdname {* + - /} {
        knit $cmdname args "
            expr \[join \${args} [list $cmdname]]
        "
    }

    knit sete {varname exp} {
        set ${varname} [expr {#{exp}}]
    }

    knit until {expr body} {
        while {!(#{expr})} ${body}
    }

    knit ?: {cond val1 val2} {
        if {#{cond}} {lindex ${val1}} else {lindex ${val2}}
    }

    knit finally {init finally do} {
        #{init}
        try ${do} finally ${finally}
    }

	test knit {} -setup $setup1 -body {
		lappend res [empty]
        lappend res [double 8]
        lappend res [exp2 5]
        set var1 18
        clear var1
        lappend res [info exists var1]
        set var1 {one two three}
        lappend res [first $var1]
        lappend res [rest $var1]
        lappend res [last $var1]
        lappend res [drop $var1]
        lappend res [greeting? hi]
        set var1 {one two three}
        lappend res [K [last $var1] [set var1 {}]]
        set var1 four
        lappend res [yank var1]
        lappend res $var1
        set var1 {one two three}
        lappend res [lremove var1 1]
        lappend res $var1
        set var1 {one two three}
        lappend res [lpop var1]
        lappend res $var1
        set var1 {four five six}
        lappend res [lpop2 var1]
        lappend res $var1
        lappend res [+ 2 2 3]
        lappend res [sete var1 {(2+18)/5}]
        set var1 0
        until {$var1 > 10} {
            incr var1 5
        }
        lappend res $var1
        lappend res [charcount {one two three four five}]
        lappend res [charcount {one two three four} o]
        lappend res [apply [knead x {expr {${x} * ${x}}}] 5]
        lappend res [?: {1 < 0} yup nope]
        finally {lappend res starting} {lappend res finally} {lappend res doing}
        return $res
	} -cleanup $cleanup1 -result [sl {
		{}
        16 
        25
        0
        one
        [list two three]
        three
        {one two}
        1
        three
        four
        {}
        {one three}
        {one three}
        three
        {one two}
        six
        {four five}
        7
        4
        15
        4
        3
        25
        nope
        starting
        doing
        finally
    }] 

	test knit_level {} -setup $setup1 -body {
		knit p1 {} {
			set var1 3
		}
		set var1 1
		p1
		set var1
	} -cleanup $cleanup1 -result {3}

	test knead_scripted {} -setup $setup1 -body {
		set script [knead {} {
			set x {1 2}
			set y {3 4}
		} {
			[` foreach x $x y $y {
				lappend res ${x} ${y}
			}]
			set res
		}]
		apply [list {*}$script [namespace current]]

		set script [knead {} {
			set res {}
			[` foreach x {{lappend res 1} {lappend res 2}} \
				y  {{lappend res 3} {lappend res 4}} {
				#{x}
				#{y}
			}][`
				foreach x {{lappend res 5} {lappend res 6}} {
					#{x}
				}
			]
			return $res
		}]
		apply [list {*}$script [namespace current]]
		
	} -cleanup $cleanup1 -result [sl {
		1 3 2 4 5 6
	}]

	test knead_scripted_2 {} -setup $setup1 -body {
		set script [knead {} {
			set res {}
			[` foreach x {{lappend res 1} {lappend res 2}} \
				y  {{lappend res 3} {lappend res 4}} {
				#{x}
				#{y}
			}]
			return $res
		}]
		apply [list {*}$script [namespace current]]
		
	} -cleanup $cleanup1 -result [sl {
		1 3 2 4
	}]

	test knot {} -setup $setup1 -body {
		set var1 one
		set var2 two
		set var3 three
		lappend res [knot {
			set b [list ${var1} ${var2} ${var3} ${var4}]
		} var4 howdy]

		lappend res [knot {
			lindex "${var3} ${var1} ${var2}"
		}]
	} -cleanup $cleanup1 -result [sl {
		{one two three howdy}
		{three one two}
	}]

	test prescript {} -setup $setup1 -body {
		knit p1 {var1 var2} {
			set var1 [expr {$var1 * 2}]
			set var2 hello
		} {
			lappend res ${var1} ${var2}
		}
		p1 3 5
		set res
	} -cleanup $cleanup1 -result [sl {
		6 hello
	}]

	cleanupTests
}