Lexical scoping in Tcl

let.tcl

#!/usr/bin/env TEST=1 tclsh
# Lexical scoping in Tcl

proc let {block args} {
  try {
    set captured_vars [uplevel [list capture [block args]]]
    set all_var_names [uplevel {info vars}]
    
    foreach var [block args] value $args {
      uplevel [list catch [list unset $var]]
      uplevel [list set $var $value]
    }
    
    uplevel [block body]
    
  } finally {
    foreach var [block args] {
      uplevel [list catch [list unset $var]]
    }
    
    foreach var [uplevel {info vars}] {
      if {[lsearch -exact $all_var_names $var] == -1} {
        uplevel [list unset $var]
      }
    }
    
    uplevel [list restore $captured_vars]
  }
}

proc yield args {
  uplevel 2 [list apply [list let [uplevel block]] $args]
}

proc apply {command arguments} {
  uplevel [concat $command $arguments]
}

proc block {{part ""}} {
  upvar block block

  if {$part eq "args"} {
    first $block
  } elseif {$part eq "body"} {
    last $block
  } elseif {$part eq "arity"} {
    llength [first $block]
  } else {
    set block
  }
}

#------------------------------------------------------------------------------

proc all? {list {block {x {return $x}}}} {
  foreach value $list {
    if [false? [yield $value]] {
      return 0
    }
  }
  return 1
}

proc any? {list {block {x {return $x}}}} {
  foreach value $list {
    if [true? [yield $value]] {
      return 1
    }
  }
  return 0
}

proc map {list block} {
  set result [list]
  foreach [block args] $list {
    set values [list]
    foreach value [block args] {
      lappend values [set $value]
    }
    lappend result [apply yield $values]
  }
  return $result
}

proc detect {list block} {
  foreach value $list {
    if [true? [yield $value]] {
      return $value
    }
  }
}

proc select {list block} {
  set result [list]
  foreach value $list {
    if [true? [yield $value]] {
      lappend result $value
    }
  }
  return $result
}

proc reject {list block} {
  set result [list]
  foreach value $list {
    if [false? [yield $value]] {
      lappend result $value
    }
  }
  return $result
}

proc inject {list memo block} {
  foreach value $list {
    set memo [yield $memo $value]
  }
  return $memo
}

#------------------------------------------------------------------------------

proc capture {vars {level 1}} {
  set arrays [set scalars [list]]
  
  foreach var [uplevel $level {info vars}] {
    if {$vars eq "-all" || [lsearch -exact $vars $var] != -1} {
      if [uplevel $level [list array exists $var]] {
        lappend arrays $var [uplevel $level [list array get $var]]
      } else {
        lappend scalars $var [uplevel $level [list set $var]]
      }
    }
  }
  
  list scalars $scalars arrays $arrays
}

proc restore {captured_vars {level 1}} {
  foreach {type vars} $captured_vars {
    foreach {var value} $vars {
      if {$type eq "scalars"} {
        uplevel $level [list set $var $value]
      } elseif {$type eq "arrays"} {
        uplevel $level [list array set $var $value]
      }
    }
  }
}

#------------------------------------------------------------------------------

proc try {script1 finally script2} {
  # from http://wiki.tcl.tk/990
  
  if {$finally ne "finally"} {
    return -code error "syntax error: should be \"[lindex [info level 0] 0] script1 finally script2\""
  }
  
  set status [catch {uplevel 1 $script1} result1]
  if {$status == 1} {
    set info $::errorInfo
    set code $::errorCode
  }
  
  switch -exact -- [catch {uplevel 1 $script2} result2] {
    0 {
      switch -exact -- $status {
        0 {return $result1}
        1 {return -code error -errorcode $code -errorinfo $info $result1}
        2 {return -code return $result1}
        3 {return -code break}
        4 {return -code continue}
        default {return -code $code $result1}
      }
    }
    1 {return -code error -errorcode $::errorCode -errorinfo "$::errorInfo\n    (\"finally\" block)" $result2}
    2 {return -code return $result2}
    3 {return -code break}
    4 {return -code continue}
    default {return -code $code $result2}
  }
}

#------------------------------------------------------------------------------

proc first list {lindex $list 0}

proc last list {lindex $list end}

proc true? value {expr ![false? $value]}

proc false? value {string is false $value}

#------------------------------------------------------------------------------

if {!([info exists env] && [string length [array get env TEST]])} return

namespace eval test {
  variable passed
  variable failed

  proc pass {} {
    variable passed
    incr passed
    puts -nonewline .
  }

  proc fail {} {
    variable failed
    variable current
    lappend failed [list $current [info level -2]]
    puts -nonewline F
  }

  proc assert value {
    if $value pass else fail
  }

  proc assert_equal {expected actual} {
    assert [expr {$expected == $actual}]
  }
  
  proc run {} {
    variable passed
    variable failed
    variable current
    
    set passed 0
    set failed [list]
    set tests 0
    
    foreach test [namespace eval cases {info procs test_*}]  {
      incr tests
      set current $test
      namespace eval cases $test
      set current ""
    }
    
    set failures [llength $failed]
    set assertions [expr {$passed + $failures}]
    puts "\n$tests tests, $assertions assertions, $failures failures"
    puts [join $failed \n]
  }

  namespace export assert assert_equal run

  namespace eval cases {
    namespace import ::test::*
  
    proc capture_with_no_locals {} {
      capture -all
    }
    
    proc capture_with_one_scalar {} {
      set x "hello world"
      capture -all
    }
    
    proc capture_with_one_array {} {
      set y(1) hello
      set y(2) world
      capture -all
    }
    
    proc capture_with_multiple_scalars_and_arrays vars {
      set a "hello world"
      set b "goodbye world"
      set c(foo) bar
      set d(baz) quux
      capture $vars
    }
    
    proc capture_with_level {} {
      capture foo 2
    }
    
    proc restore_with_level captured_vars {
      restore $captured_vars 2
    }
    
    proc call_proc_that_yields_from_proc_with_local m {
      call_block_with_argument n {n {capture -all}}
    }

    proc call_block_with_argument {n block} {
      yield $n
    }
    
    proc test_capture_with_no_locals {} {
      assert_equal {scalars {} arrays {}} [capture_with_no_locals]
    }
    
    proc test_capture_with_one_scalar {} {
      assert_equal {scalars {x {hello world}} arrays {}} [capture_with_one_scalar]
    }
    
    proc test_capture_with_one_array {} {
      assert_equal {scalars {} arrays {y {1 hello 2 world}}} [capture_with_one_array]
    }
    
    proc test_capture_with_multiple_scalars_and_arrays {} {
      assert_equal {scalars {a {hello world}} arrays {}} [capture_with_multiple_scalars_and_arrays a]
      assert_equal {scalars {a {hello world}} arrays {c {foo bar}}} [capture_with_multiple_scalars_and_arrays {a c}]
      assert_equal {scalars {} arrays {}} [capture_with_multiple_scalars_and_arrays nonexistent]      
      assert_equal {scalars {vars -all a {hello world} b {goodbye world}} arrays {c {foo bar} d {baz quux}}} [capture_with_multiple_scalars_and_arrays -all]
    }
    
    proc test_capture_with_level {} {
      assert_equal {scalars {} arrays {}} [capture_with_level]
      set foo bar
      assert_equal {scalars {foo bar} arrays {}} [capture_with_level]
    }
    
    proc test_restore_from_empty_capture_data {} {
      assert_equal {scalars {} arrays {}} [capture -all]
      restore {scalars {} arrays {}}
      assert_equal {scalars {} arrays {}} [capture -all]
      set foo bar
      restore {scalars {} arrays {}}
      assert_equal {scalars {foo bar} arrays {}} [capture -all]
    }
    
    proc test_restore_with_one_scalar {} {
      restore [capture_with_one_scalar]
      assert_equal "hello world" $x
    }

    proc test_restore_with_one_array {} {
      restore [capture_with_one_array]
      assert_equal hello $y(1)
      assert_equal world $y(2)
    }
    
    proc test_restore_with_multiple_scalars_and_arrays {} {
      restore [capture_with_multiple_scalars_and_arrays -all]
      assert_equal "hello world" $a
      assert_equal "goodbye world" $b
      assert_equal bar $c(foo)
      assert_equal quux $d(baz)
    }
    
    proc test_restore_with_level {} {
      restore_with_level [capture_with_one_scalar]
      assert_equal "hello world" $x
    }
    
    proc test_let {} {
      set x hello
      assert_equal 3 [let {{x y} {expr $x + $y}} 1 2]
      assert_equal hello $x
      assert_equal 1 [catch {set y}]
    }
    
    proc test_let_should_not_leak_temporary_block_variables {} {
      assert_equal 1 [catch {set foo}]
      let {x {set foo $x}} foo
      assert_equal 1 [catch {set x}]
      assert_equal 1 [catch {set foo}]
    }
   
    proc test_yield_evaluates_block_in_the_right_scope {} {
      assert_equal {scalars {m m n n} arrays {}} [call_proc_that_yields_from_proc_with_local m]
    }
   
    proc test_map {} {
      assert_equal {} [map {} {x {expr $x + 1}}]
      assert_equal {1 2 3} [map {0 1 2} {x {expr $x + 1}}]
    }
    
    proc test_map_with_two_arguments {} {
      assert_equal {3 7 11} [map {1 2 3 4 5 6} {{x y} {expr $x + $y}}]
    }
    
    proc test_inject {} {
      assert_equal 10 [inject {1 2 3 4} 0 {{sum value} {expr $sum + $value}}]
    }
    
    proc test_map_nested_in_let {} {
      assert_equal {1 2 3} [let {n {map {0 1 2} {m {expr $n + $m}}}} 1]
    }
  }
}

test::run