#! /bin/env tclsh
# Copyright 2017, 2020 Poor Yorick
#
# {ycl knit} is free software: you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation, either version 3 of the License, or (at your option) any later
# version.
#
# {ycl knit} is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along with
# {ycl knit}. If not, see <https://www.gnu.org/licenses/>.
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
}