Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Squashed 'vendor/underscore-tcl/' content from commit 63e1c98

git-subtree-dir: vendor/underscore-tcl
git-subtree-split: 63e1c988ff8c8632edc729f28bfdd314e4e03b83
  • Loading branch information...
commit 649b2b64aaf92bc8f974fce2ea15086762707f90 0 parents
@arthurschreiber authored
34 benchmarks/each.tcl
@@ -0,0 +1,34 @@
+set auto_path [concat [file join [file dirname [info script]] ".."] $auto_path]
+
+package require underscore
+
+set numbers [list]
+for {set i 0} {$i < 100} { incr i } { lappend numbers $i }
+
+puts "foreach with empty body"
+puts [time {
+ foreach num $numbers {
+ # Do nothing...
+ }
+} 1000]
+
+puts "_::each with empty body"
+puts [time {
+ _::each $numbers {{num} {
+ # Do nothing...
+ }}
+} 1000]
+
+puts "foreach with expression"
+puts [time {
+ foreach num $numbers {
+ expr { $num * $num }
+ }
+} 1000]
+
+puts "_::each with expression"
+puts [time {
+ _::each $numbers {{num} {
+ expr { $num * $num }
+ }}
+} 1000]
21 benchmarks/map.tcl
@@ -0,0 +1,21 @@
+set auto_path [concat [file join [file dirname [info script]] ".."] $auto_path]
+
+package require underscore
+
+set numbers [list]
+for {set i 0} {$i < 100} { incr i } { lappend numbers $i }
+
+puts "mapping using foreach with expression"
+puts [time {
+ set result [list]
+ foreach num $numbers {
+ lappend result [expr { $num * $num }]
+ }
+} 1000]
+
+puts "_::map with expression"
+puts [time {
+ _::map $numbers {{num} {
+ expr { $num * $num }
+ }}
+} 1000]
1  pkgIndex.tcl
@@ -0,0 +1 @@
+package ifneeded underscore 0.1 "source $dir/underscore.tcl"
348 spec/underscore_spec.tcl
@@ -0,0 +1,348 @@
+lappend auto_path [file join [file dirname [info script]] ".."]
+
+package require underscore
+
+describe "_::yield" {
+ after each {
+ if { [info exists ::yielded] } {
+ unset ::yielded
+ }
+
+ if { [info exists ::level] } {
+ unset ::level
+ }
+
+ if { [info exists ::yielded_args] } {
+ unset ::yielded_args
+ }
+ }
+
+ describe "when passed a proc name" {
+ proc helper_proc {} {
+ set ::yielded true
+ }
+
+ proc helper_proc_with_args { args } {
+ set ::yielded_args $args
+ }
+
+ it "executes the passed proc" {
+ apply {{} { _::yield helper_proc }}
+ expect $::yielded to be true
+ }
+
+ it "executes the passed proc with the passed arguments" {
+ apply {{} { _::yield helper_proc_with_args 1 2 3 4 }}
+ expect $::yielded_args to equal {1 2 3 4}
+ }
+ }
+
+ describe "when passed a block" {
+ it "yields the passed block" {
+ apply {{} {
+ _::yield {{} {
+ set ::yielded true
+ }}
+ }}
+
+ expect $::yielded to be true
+ }
+
+ it "yields the passed block with the passed arguments" {
+ apply {{} {
+ _::yield {{args} {
+ set ::yielded_args $args
+ }} 1 2 3 4
+ }}
+
+ expect $::yielded_args to equal {1 2 3 4}
+ }
+
+ it "yields the block in a seperate stack frame at the passed stack level" {
+ apply {{} {
+ _::yield {{} {
+ set ::level [info level]
+ }}
+ }}
+
+ expect $::level to equal [expr { [info level] + 1 }]
+ }
+
+ proc accepts_block { block } {
+ _::yield $block
+ }
+
+ it "allows accessing variables at the passed stack level using 'upvar'" {
+ set test {1 2 3}
+
+ apply {{} {
+ _::yield {{} {
+ upvar test test
+ set test {}
+ }}
+ }}
+
+ expect $test to equal {}
+
+ accepts_block {{} {
+ upvar test test
+ set test {1 2 3}
+ }}
+ expect $test to equal {1 2 3}
+ }
+
+ proc accepts_block_and_returns_executed { block } {
+ puts "Yield result: [_::yield $block]"
+ return "executed"
+ }
+
+ describe "calling return -code return inside a block" {
+ proc helper_proc {} {
+ puts [accepts_block_and_returns_executed {{} {
+ return -code return "aborted"
+ }}]
+
+ return "not aborted"
+ }
+
+ it "returns from the yielding proc" {
+ expect [
+ apply {{} {
+ _::yield {{} {
+ return -code return "return from yield"
+ }}
+ return "return from apply"
+ }}
+ ] to equal "return from yield"
+ }
+ }
+ }
+}
+
+describe "_::each" {
+ before each {
+ set ::count 0
+ set ::yielded [list]
+ }
+
+ after each {
+ unset ::count
+ unset ::yielded
+ }
+
+ it "executes the given block for each element in the list" {
+ _::each {1 2 3 4} {{x} {
+ incr ::count
+ }}
+
+ expect $::count to equal 4
+ }
+
+ it "passes each element of the list to the block" {
+ _::each {1 2 3 4} {{x} {
+ lappend ::yielded $x
+ }}
+
+ expect $::yielded to equal {1 2 3 4}
+ }
+}
+
+describe "_::map" {
+ it "continues iteration and uses the given value if return -code continue is called" {
+ expect [_::map {1 2 3 4 5} { x {
+ if { $x == 3 } { return -code continue -1 }
+ return $x
+ } }] to equal {1 2 -1 4 5}
+ }
+
+ it "breaks iteration and returns the given value if return -code break is called" {
+ expect [_::map {1 2 3 4 5} { x {
+ if { $x == 3 } { return -code break -1 }
+ return $x
+ } }] to equal -1
+ }
+}
+
+describe "_::all?" {
+ it "always returns true on an empty list" {
+ expect [_::all? {}] to be true
+ expect [_::all? {} {{e} { return false }}] to be true
+ }
+
+ describe "with no block" {
+ it "returns true if no element is falsy" {
+ expect [_::all? {1 2 -1}] to be true
+ expect [_::all? {a b c}] to be true
+ }
+
+ it "returns false if at least one element is falsy" {
+ expect [_::all? {1 2 0 -1}] to be false
+ # This might seem weird, but "f" is a falsy value in Tcl
+ expect [_::all? {a b c f}] to be false
+ expect [_::all? {true false true}] to be false
+ }
+ }
+
+ describe "with a block" {
+ it "returns true if the block never returns a falsy value" {
+ expect [_::all? {false} {{item} { return true }}] to be true
+ expect [_::all? {1 2 -1} {{item} { return true }}] to be true
+ expect [_::all? {1 2 -1} {{item} { expr { $item < 5 } }}] to be true
+ expect [_::all? {1 2 -1} {{item} { expr { 5 } }}] to be true
+ }
+
+ it "returns false if the block returns at least one falsy value" {
+ expect [_::all? {true} {{item} { return false }}] to be false
+ expect [_::all? {1 2 -1} {{item} { expr { $item > 2 } }}] to be false
+ expect [_::all? {1 2 -1} {{item} { expr { 0 } }}] to be false
+
+ }
+
+ it "returns as early as possible" {
+ set yielded [list]
+
+ _::all? { 1 2 3 false 5 6 7 } {{item} {
+ upvar yielded yielded
+ lappend yielded $item
+ return $item
+ }}
+
+ expect $yielded to equal {1 2 3 false}
+ }
+ }
+}
+
+describe "_::each" {
+ proc each_with_non_local_return {} {
+ _::each { 1 2 3 } {{x} {
+ if { $x == 2 } {
+ return -code return "non-local return"
+ } else {
+ expr { $x * $x }
+ }
+ }}
+ }
+
+ it "allows non-local returns" {
+ expect [each_with_non_local_return] to equal "non-local return"
+ }
+}
+
+describe "_::any?" {
+ it "always returns false on an empty list" {
+ expect [_::any? {}] to be false
+ expect [_::any? {} {{e} { return true }}] to be false
+ }
+
+ describe "with no block" {
+ it "returns true if at least one element is not falsy" {
+ expect [_::any? {1 2 -1}] to be true
+ expect [_::any? {a b c}] to be true
+ expect [_::any? {false 0 true}] to be true
+ }
+
+ it "returns false if all elements are falsy" {
+ expect [_::any? {false}] to be false
+ # This might seem weird, but "f" is a falsy value in Tcl
+ expect [_::any? {f}] to be false
+ expect [_::any? {false 0 fal fa f}] to be false
+ }
+ }
+
+ describe "with a block" {
+ it "returns true if at least one element is not falsy" {
+ expect [_::any? {false} {{item} { return true }}] to be true
+ expect [_::any? {false} {{item} { return 1 }}] to be true
+
+ expect [_::any? {1 2 -1} {{item} { return "test" }}] to be true
+ expect [_::any? {1 2 -1} {{item} { expr { $item < 1 } }}] to be true
+ expect [_::any? {1 2 -1} {{item} { expr { 5 } }}] to be true
+ }
+
+ it "returns false if the block never returns a non-falsy value" {
+ expect [_::any? {true test 1234} {{item} { return false }}] to be false
+ expect [_::any? {1 2 -1} {{item} { return 0 }}] to be false
+ expect [_::any? {1 2 -1} {{item} { expr { $item < -10 } }}] to be false
+ }
+
+ it "returns as early as possible" {
+ set yielded [list]
+
+ _::any? { 1 2 3 false 5 6 7 } {{item} {
+ upvar yielded yielded
+ lappend yielded $item
+ return $item
+ }}
+
+ expect $yielded to equal {1}
+ }
+ }
+}
+
+describe "_::first" {
+ describe "when passed no number" {
+ it "returns the first element from the passed list" {
+ expect [_::first {1 2 3 4}] to equal 1
+ }
+ }
+
+ describe "when passed a number" {
+ it "returns the first n elements from the passed list" {
+ expect [_::first {1 2 3 4} 0] to equal {}
+ expect [_::first {1 2 3 4} 3] to equal {1 2 3}
+ expect [_::first {1 2 3 4} 5] to equal {1 2 3 4}
+ }
+ }
+
+ it "can be passed to _::map" {
+ expect [_::map {{1 2 3} {1 2 3}} _::first] to equal {1 1}
+ }
+}
+
+describe "_::initial" {
+ describe "when passed no number" {
+ it "returns everything but the last element from the passed list" {
+ expect [_::initial {1 2 3 4}] to equal {1 2 3}
+ }
+ }
+
+ describe "when passed a number" {
+ it "returns everything but the last n elements from the passed list" {
+ expect [_::initial {1 2 3 4} 0] to equal {1 2 3 4}
+ expect [_::initial {1 2 3 4} 2] to equal {1 2}
+ expect [_::initial {1 2 3 4} 5] to equal {}
+ }
+ }
+
+ it "can be passed to _::map" {
+ expect [_::map {{1 2 3} {1 2 3}} _::initial] to equal {{1 2} {1 2}}
+ }
+}
+
+describe "_::index_of" {
+ it "returns the index at which the given value can be found in the list" {
+ expect [_::index_of {1 2 3} 2] to equal 1
+ }
+
+ it "returns -1 if the given value can not be found in the list" {
+ expect [_::index_of {1 2 3 4} 5] to equal -1
+ }
+}
+
+describe "_::times" {
+ it "executes the passed block n times" {
+ set result [list]
+ _::times 0 {{n} {
+ upvar result result
+ lappend result $n
+ }}
+ expect $result to equal [list]
+
+ set result [list]
+ _::times 3 {{n} {
+ upvar result result
+ lappend result $n
+ }}
+ expect $result to equal [list 0 1 2]
+ }
+}
262 underscore.tcl
@@ -0,0 +1,262 @@
+# underscore.tcl - Collection of utility methods
+#
+# Inspired by Underscore.js - http://documentcloud.github.com/underscore/ and
+# the Ruby Enumerable module.
+#
+# This package provides a collection of different utility methods, that try to
+# bring functional programming aspects known from other programming languages
+# like Ruby or JavaScript to Tcl.
+package provide underscore 0.1
+
+namespace eval _ {
+ # Yields a block of code in a specific stack-level.
+ #
+ # This function yields the passed block of code in a seperate stack frame
+ # (by wrapping it into an ::apply call), but allows easy access to
+ # surrounding variables using the tcl-native upvar mechanism.
+ #
+ # Yielding the code in an anonymous proc prevents the leakage of variable
+ # definitions, while still giving the block access to surrounding variables
+ # using upvar.
+ #
+ # @example Calculating the first n Fibonnacci numbers
+ # proc fib_up_to { max block } {
+ # set i1 [set i2 1]
+ #
+ # while { $i1 <= $max } {
+ # _::yield $block $i1
+ # set tmp [expr $i + $i2]
+ # set i1 $i2
+ # set i2 $tmp
+ # }
+ # }
+ #
+ # fib_up_to 50 {{n} { puts $n }} ;# prints the fibonnaci sequence up to 50
+ #
+ # @example Automatic resource cleanup
+ # # Guarantees that the file descriptor is closed,
+ # # even in case of an error being raised while executing the block.
+ # proc file_open { path mode block } {
+ # open $fd
+ #
+ # # Catch any exceptions that might happen
+ # set error [catch { _::yield $block $fd } value options]]
+ #
+ # catch { close $fd }
+ #
+ # if { $error } {
+ # # if an exception happened, rethrow it
+ # return {*}$options $value
+ # } else {
+ # # Do nothing
+ # return
+ # }
+ # }
+ #
+ # file_open "/tmp/test" "w" {{fd} {
+ # puts $fd "test"
+ # }}
+ #
+ # If you want to return from the stack frame where the method that yields a block
+ # was called from, you can use 'return -code return'.
+ #
+ # @example Returning from the stack frame that called the yielding method.
+ # proc return_to_calling_frame {} {
+ # _::each {1 2 3 4} {{item} {
+ # if { $item == 2 } {
+ # # Stops the iteration and will return "done" from "return_to_calling_frame"
+ # return -code return "done"
+ # }
+ # }}
+ # # This return will not be executed
+ # return "fail"
+ # }
+ #
+ # 'return -code break ?value?' and 'return -code continue ?value?' have special
+ # meanings inside a block.
+ #
+ # @example Passing a block down, by specifying a yield level
+ # # Reverse each, like _::each, but in reverse
+ # proc reverse_each { list block } {
+ # _::each [lreverse $list] {{args} {
+ # # Include the passed block
+ # upvar block block
+ #
+ # # we have to increase the yield level here, as we want to
+ # # execute the block on the same stack level as reverse_each
+ # # was called on
+ # uplevel 1 [list _::yield $block {*}$args]
+ # }}
+ # }
+ #
+ # @example Passing a block down by upleveling the call to each.
+ # # Reverse each, like _::each, but in reverse
+ # proc reverse_each { list block } {
+ # uplevel [list _::each [lreverse $list] $block]
+ # }
+ #
+ # @param block_or_proc The block (anonymous function) or proc to be executed
+ # with the passed arguments. If it's a block, it can be either in the form
+ # of {args block} or {args block namespace} (see the documentation for ::apply).
+ # @param args The arguments with which the passed block should be called.
+ #
+ # @return Return value of the block.
+ proc yield { block_or_proc args } {
+ # Stops type shimmering of $block_or_proc when calling llength directly
+ # on it, which in turn causes the lambda expression to be recompiled
+ # on each call to _::yield
+ set block_dup [concat $block_or_proc]
+
+ catch {
+ if { [llength $block_dup] == 1 } {
+ uplevel 2 [list $block_or_proc {*}$args]
+ } else {
+ uplevel 2 [list apply $block_or_proc {*}$args]
+ }
+ } result options
+
+ dict incr options -level 1
+ return -options $options $result
+ }
+
+ # Iterates over the passed list, yielding each element in turn to the
+ # passed iterator
+ proc each { list iterator } {
+ foreach item $list {
+ yield $iterator $item
+ }
+
+ return $list
+ }
+
+ proc map { list iterator } {
+ set result [list]
+
+ foreach item $list {
+ set status [catch { yield $iterator $item } return_value options]
+
+ switch -exact -- $status {
+ 0 - 4 {
+ # 'normal' return and errors
+ lappend result $return_value
+ }
+ 3 {
+ # 'break' should return immediately
+ return $return_value
+ }
+ default {
+ # Just pass through everything else
+ return -options $options $return_value
+ }
+ }
+ }
+
+ return $result
+ }
+
+ proc reduce { list iterator memo } {
+ foreach item $list {
+ set memo [yield $iterator $memo $item]
+ }
+ return $memo
+ }
+
+ # Executes the passed iterator with each element of the passed list.
+ # Returns true if the passed block never returns a 'falsy' value.
+ #
+ # When no explicit iterator is passed, all? will return true
+ # if none of the list elements is a falsy value.
+ proc all? { list {iterator {{x} { return $x }}} } {
+ foreach e $list {
+ if { [string is false [yield $iterator $e]] } {
+ return false
+ }
+ }
+
+ return true
+ }
+ interp alias {} ::_::every? {} ::_::all?
+ namespace export all? every?
+
+ # Executes the passed iterator with each element of the passed list.
+ # Returns true if the passed block returns at least one value that
+ # is not 'falsy'.
+ #
+ # When no explicit iterator is passed, any? will return true
+ # if at least one of the list elements is not a falsy value.
+ proc any? { list {iterator {{x} { return $x }}} } {
+ foreach e $list {
+ if { [expr { ![string is false [yield $iterator $e]] }] } {
+ return true
+ }
+ }
+
+ return false
+ }
+ interp alias {} ::_::some? {} ::_::any?
+ namespace export some? any?
+
+ # Returns the first n elements from the passed list.
+ proc first { list {n 1}} {
+ lrange $list 0 $n-1
+ }
+
+ # Returns all elements from the passed list excluding the last n.
+ proc initial { list {n 1}} {
+ lrange $list 0 end-$n
+ }
+
+ proc index_of { list value {is_sorted false} } {
+ if { ![string is false $is_sorted] } {
+ lsearch -sorted -exact $list $value
+ } else {
+ lsearch -exact $list $value
+ }
+ }
+
+ # Returns a sorted copy of list. Sorting is based on the return
+ # values of the execution of the iterator for each item.
+ proc sort_by { list iterator } {
+ set list_to_sort [_::map $list {{item} {
+ upvar iterator iterator
+ list [uplevel [list yield $iterator $item] $item
+ }}]
+
+ set sorted_list [lsort $list_to_sort]
+
+ _::map $sorted_list {{pair} {
+ lindex $pair 1
+ }}
+ }
+
+ # Executes the passed block n times.
+ proc times { n iterator } {
+ for {set i 0} {$i < $n} {incr i} {
+ yield $iterator $i
+ }
+ }
+
+ proc take_while { list iterator } {
+ set result [list]
+
+ foreach item $list {
+ if { ![yield $iterator $item] } {
+ break
+ }
+
+ lappend result $item
+ }
+
+ return $item
+ }
+
+ proc group_by { list iterator } {
+ set result [dict create]
+
+ foreach item $list {
+ dict lappend result [yield $iterator $item] $item
+ }
+
+ return $result
+ }
+}
Please sign in to comment.
Something went wrong with that request. Please try again.