ytcl.tcl

#!/usr/bin/env tclsh
# ytcl.tcl - Tcl port of shy Bash DSL

namespace eval ::ytcl {
    variable current_level 0

    # Return the current indentation string based on nesting level
    proc indent {} {
        variable current_level
        return [string repeat "   " $current_level]
    }

    # Increment / decrement current indent level
    proc + {} { variable current_level; incr current_level }
    proc - {} { variable current_level; incr current_level -1 }

    # Core generator functions
    proc _df {self name {arg ""}} {
        if {$self eq "s"} {
            return "def ${name}(self,${arg}):"
        } else {
            return "def ${name}(${arg}):"
        }
    }

    proc _rt {arg} { return "return $arg" }

    proc _de {self name {arg ""}} {
        if {$self eq "s"} {
            return "def ${name}(self,event=None,${arg}):"
        } else {
            return "def ${name}(event=None,${arg}):"
        }
    }

    proc _fc {self func {arg ""} {param ""}} {
        switch -- $self {
            "s" { return "self.${func}(${arg})" }
            "z" { return "self.${func}(self.${arg})" }
            "k" { return "${func}(self.${arg})" }
            default { return "${func}(${arg})" }
        }
    }

    proc _vf {scope name func {arg ""} {extra ""}} {
        set t_pref ""
        set f_pref ""
        set a_pref ""

        if {$scope eq "s"} {
            set t_pref "self."
        } elseif {$scope eq "z"} {
            set t_pref "self."
            set f_pref "self."
            set a_pref "self."

        } elseif {$scope eq "k"} {
            set f_pref "self."

        } elseif {$scope eq "a"} {
            set f_pref "self."
            set a_pref "self."

        } elseif {$scope eq "t"} {
            set t_pref "self."
            set f_pref "self."
        }
        set line "${t_pref}${name} = ${f_pref}${func}(${a_pref}${arg})"
        if {$extra ne ""} { append line " $extra" }
        return $line
    }

    proc _va {self name val} {
        switch -- $self {
            "s"  { return "self.$name = $val" }
            "k"  { return "$name = self.$val" }
            "z" { return "self.$name = self.$val" }
            default { return "$name = $val" }
        }
    }

    proc _wi {self func arg name} {
        if {$self eq "a"} {
            return "with ${func}(self.${arg}) as $name:"
        } elseif {$self eq "s"} {
            return "with self.${func}(${arg}) as $name:"
        } else {
            return "with ${func}(${arg}) as $name:"
        }
    }

    proc _ytr {} { return "try:" }
    proc _exc {} { return "except Exception as e:" }

    proc _ff {f val {p ""} {param ""}} {
        switch -- $f {
            "f"   { return "if ${val}(${p}) $param:" }
            "s"   { return "if self.${val} $p $param:" }
            "k"  {
                if {$param ne ""} {
                    return "if self.${val}(${p}) $param:"
                } else {
                    return "if self.${val}(${p}):"
                }
            }
            default { return "if ${val} $p:" }
        }
    }

    proc _ef {f val {p ""}} {
        if {$f eq "f"} {
            return "elif ${val}(${p}):"
        } else {
            return "elif ${val}:"
        }
    }

    proc _el {} { return "else:" }
    proc _br {} { return "break" }

    proc _fr {f i l {p ""}} {
        switch -- $f {
            "f"  { return "for $i in ${l}(${p}):" }
            "k"  { return "for $i in self.${l}(${p}):" }
            "s"  { return "for $i in self.$l:" }
            default { return "for $i in $l:" }
        }
    }

    proc _ac {self name cc} {
        switch -- $self {
            "s"   { return "self.$name += $cc" }
            "z"  { return "self.$name += self.$cc" }
            "k"  { return "$name += self.$cc" }
            default { return "$name += $cc" }
        }
    }

    proc _dc {self name cc} {
        switch -- $self {
            "s"   { return "self.$name -= $cc" }
            "z"  { return "self.$name -= self.$cc" }
            "k"  { return "$name -= self.$cc" }
            default { return "$name -= $cc" }
        }
    }
    proc _fin {} { return "finally:" }
    proc _ps {} { return "pass" }
    proc _wh {cond} { return "while $cond:" }
    proc _cnt {} { return "continue" }

    # Metaprogramming:
    #
    set commands {br df rt de fc vf va ff ef el fr ac dc wi ytr exc wh cnt fin ps}

    foreach cmd $commands {
        proc ::ytcl::$cmd {args} \
            "puts -nonewline \[indent\]; puts \[eval _$cmd \$args\]"
    }

    #generate $level$cmd procs for level 0..5
    #~ set commands {df rt de fc vf va ff ef el fr ac dc wi ytr exc wh cnt}
    #~ for {set i 0} {$i <= 5} {incr i} {
        #~ foreach cmd $commands {
            #~ # Create a proc like "0df", "1df", ...
            #~ proc ::ytcl::${i}${cmd} {args} [string map [list %i $i %cmd $cmd] {
                #~ variable indents
                #~ puts -nonewline [lindex $indents %i]
                #~ puts [eval _%cmd $args]
            #~ }]
        #~ }
    #~ }

    # Toplevel global commands
    proc bang {} {
        puts "#!/usr/bin/env python3"
        puts "#!ytcl.tcl;"
    }

    proc cl {name {base ""}} { puts "class ${name}(${base}):" }
    proc imp {pkg} { puts "import $pkg" }
    proc as {pkg alias} { puts "import $pkg as $alias" }
    proc frm {module name} { puts "from $module import $name" }
    proc mn {class windowTitle} {
        puts "if __name__ == '__main__':"
        puts "   runIt = ${class}()"
        puts "   runIt.title(\"$windowTitle\")"
        puts "   runIt.mainloop()"
    }

    ########################################################
    # keep these as an example of tcl power
    # cla class_name base1 base2
    proc cla {name args} {
        puts "class ${name}([join $args {, }]):"
    }

    # dec decorator_name    @decorator_name
    # dec "decorator_name(args)"    @decorator_name(args)    (pass as a single string)
    # dec decorator_name arg1 arg2    @decorator_name(arg1, arg2)
    proc dec {name args} {
        if {[llength $args] == 0} {
            puts -nonewline [indent]
            puts "@$name"
        } else {
            # If the first extra argument looks like a parenthesis group, use it as is
            if {[string match "(*)" $args]} {
                puts -nonewline [indent]
                puts "@${name}$args"
            } else {
                puts -nonewline [indent]
                puts "@${name}([join $args {, }])"
            }
        }
    }
    #############################################

    # cm "some text"    # some text
    proc cm {text} {
        puts -nonewline [indent]
        puts "# $text"
    }

    proc doc {text} {
        puts -nonewline [indent]
        puts "\"\"\"${text}\"\"\""
    }

    # Utilities
    proc bd {self widget pairs} {
      foreach {key handler} $pairs {
        fc $self ${widget}.bind "\"${key}\", self.${handler}"
      }
    }
    proc sf {empty index pattern} {
        va l $index {[(m.start(),m.end()) for m in finditer(r'$pattern', data)]}
        fr - start,end $index
        +
        fc s this_text_box.tag_add {"$index",f"1.0+{start}c",f"1.0+{end}c"}
        -
    }
    namespace export *
}

namespace import ::ytcl::*

proc unknown {args} {
  puts -nonewline [::ytcl::indent]
  puts [join $args " "]
}