[Keith Vetter] 2018-05-03: @decorators.tsh -- A tcl implementation of Python decorators

** Changes **

   2019-02-10:   [PYK]: Replaced `@memoize` with in implementation that doesn't require an external variable, and is careful not to generate a string representation of its memory.


** Description **

In [Python], decorators are syntactic sugar that lets you wrap a function to provide some extra functionality
[https://www.python.org/dev/peps/pep-0318/]. They're used for a bunch of different reasons, from memoization and 
timing to static methods and getters/setters[https://realpython.com/primer-on-python-decorators/]. 

Once you start thinking in terms of wrapping functions, it's easy to come up with more and more instances 
when they can be very helpful.

Here's a short list of some useful tcl decorators that I've come up with in the past few months:

   * @namedArgs -- lets you call functions like ''myFunc var1=value1 var2=value2''
   * http://wiki.tcl.tk/55464%|%@tip288%|% -- implementation of https://core.tcl.tk/tips/doc/trunk/tip/288.md%|%tip288%|%, ''args anywhere in the procedure argument list''
   * @memoize -- automatically memoizes any function
   * @autoIndex -- allow ''a+b'' type arguments (ala lindex) for any function
   * @passByReference -- turns all ''&arg'' into a pass by reference argument 
   * @debug -- prints the arguments a function is called with and its return value
   * @time -- prints how much time a function took to execute

The syntax mimics Python:
 @namedArgs \
 proc MyFunction {...} {...}

Here are the implementations and an example how to use each one:

======
proc @namedArgs {defaults p pname pargs lambda} {
    # Creates dictinary argsDict with values in $defaults merged
    # with all key=value items in $args
    if {$p ne "proc"} { error "bad syntax: $p != 'proc'" }
    if {[lindex $pargs end] ne "args"} {
        proc $pname $pargs $lambda
        return
    }
    set body "
        set argsDict \[dict create $defaults\]
        set newArgs {}
        foreach arg \$args {
            if {\[regexp {^(.*)=(.*)$} \$arg . key value\]} {
                dict set argsDict \$key \$value
            } else {
                lappend newArgs \$arg
            }
        }
        set args \$newArgs
        $lambda
    "
    proc $pname $pargs $body
    return $pname
}

@namedArgs {name1 default1 name2 default2 name3 default3 name4 default4} \
proc test_namedArgs {args} {
    puts "In test_namedArgs with argsDict: "
    set longest [tcl::mathfunc::max 0 {*}[lmap key [dict keys $argsDict] {string length $key}]]
    dict for {key value} $argsDict {
        puts [format "    %-${longest}s = %s" $key $value]
    }
}
test_namedArgs name1=value1 name3=value3 other args name4=value4

# ================

proc @tip288 {p {pname ""} {pargs ""} {lambda ""}} {
    if {$p ne "proc"} {
        if {$pname ne "" || $pargs ne "" || $lambda ne ""} {error "bad synax: $p != 'proc'"}
        set pname $p
        set pargs [info args $pname]
        set lambda [info body $pname]
    }
    set idx [lsearch $pargs "args"]
    if {$idx == -1 || $idx == [llength $pargs] - 1} {
        proc $pname $pargs $lambda
        return
    }
    set pre [lrange $pargs 0 $idx]
    set post [lrange $pargs $idx+1 end]
    set body "
        set args \[lreverse \[lassign \[lreverse \$args\] [lreverse $post]\]\]
        $lambda
    "
    proc $pname $pre $body
    return $pname
}

@tip288 \
proc test_@tip288 {a b args c d} {
    set msg "a: '$a' b: '$b' c: '$c' d: '$d' =>  args: '$args'"
    puts $msg
    return $msg
}
test_@tip288 A B these are random arguments for testing C D

# ================
proc @memoize {p pname pargs body} {
    if {$p ne {proc}} {error [list {bad syntax} $p != proc]}

    uplevel 1 [list ::proc $pname args [
        list ::apply [list {memory pargs body} {
            upvar 1 args args
            if {[dict exists $memory $args]} {
                return [dict get $memory $args]
            }
            set res [uplevel 2 [list ::apply [
                list $pargs $body [namespace current]] {*}$args]]
            dict set memory $args $res
            puts [::tcl::unsupported::representation $memory]
            proc [lindex [info level -1] 0] args [
                lreplace [info level 0] 2 2 $memory]
            return $res
        } [uplevel 1 {namespace current}]] {} $pargs $body
    ]]
}

@memoize \
proc test_@memoize {a b} {
    puts "in test_@memoize $a $b"
    return $a
}
puts [test_@memoize 1 2]
puts [test_@memoize 1 2]
puts [test_@memoize 4 3]
puts [test_@memoize 4 3]

# ================
proc @autoIndex {p pname pargs lambda} {
    if {$p ne "proc"} { error "bad synax: $p != 'proc'"}

    proc $pname $pargs "
         set argVals {}
         foreach arg {$pargs} {
             set val \[set \$arg\]
             if {\[regexp \{^-?\\d+\[+-\]-?\\d+$\} \$val\]} { set val \[expr \$val\] }
             lappend argVals \$val
         }
         apply {{$pargs} {$lambda}} {*}\$argVals
    "
}

@autoIndex \
proc test_autoIndex {a b c} {
    puts "a is $a and b is $b and c is $c"
}
test_autoIndex hello 3 4+5

# ================
proc @passByReference {p {pname ""} {pargs ""} {lambda ""}} {
    if {$p ne "proc"} {
        if {$pname ne "" || $pargs ne "" || $lambda ne ""} {error "bad synax: $p != 'proc'"}
        set pname $p
        set pargs [info args $pname]
        set lambda [info body $pname]
    }
    set prefix ""
    foreach arg [lsearch -all -inline -glob $pargs &*] {
        append prefix "upvar 1 \${$arg} [string range $arg 1 end];\n"
    }
    proc $pname $pargs "$prefix$lambda"
    return $pname
}

@passByReference \
proc test_@pbr {arg1 &who} {
    puts "in test_@pbr: arg1='$arg1' who='$who'"
    set who "new value for my global variable"
    return
}
set myGlobal "my global variable"
puts "myGlobal before call: $myGlobal"
test_@pbr xxx myGlobal
puts "myGlobal after call: $myGlobal"

# ================
proc @debug {p pname pargs lambda} {
    if {$p ne "proc"} { error "bad syntax: $p != 'proc'" }
    proc $pname $pargs "
        set msg \"DEBUG: calling $pname \"
        foreach arg {$pargs} {
            append msg \"\$arg=\[set \$arg\] \"
        }
        puts \$msg
        try {
            set start \[clock microseconds\]
            set argVals \[lmap var {$pargs} {set \$var}]
            set rval \[apply {{$pargs} {$lambda}} {*}\$argVals\]
        } finally {
            puts \"DEBUG: $pname returned \$rval\"
        }
     "
}

@debug \
proc test_debug {a b c} {
    puts "a: $a b: $b c: $c"
    return [string length $a]
}
test_debug 1 2 3

# ================
proc @time {p {pname ""} {pargs ""} {lambda ""}} {
    if {$p ne "proc"} {
        if {$pname ne "" || $pargs ne "" || $lambda ne ""} {error "bad synax: $p != 'proc'"}
        set pname $p
        set pargs [info args $pname]
        set lambda [info body $pname]
    }
    proc $pname $pargs "
        try {
            set start \[clock microseconds\]
            set argVals \[lmap var {$pargs} {set \$var}]
            return \[apply {{$pargs} {$lambda}} {*}\$argVals\]
        } finally {
            puts \"$pname took \[expr {\[clock microseconds\] - \$start}\] microseconds\"
        }
     "
    return $pname
}
@time \
proc test_timing {n} {
    puts "in test_@timing: $n"
    after $n
    return "n is $n"
}
test_timing 500


======

<<categories>>Syntax