Posted to tcl by hardkorebob at Wed Aug 05 20:08:26 GMT 2026view raw

  1. #!/usr/bin/env tclsh
  2. # ytcl.tcl - Tcl port of shy Bash DSL
  3.  
  4. namespace eval ::ytcl {
  5. variable current_level 0
  6.  
  7. # Return the current indentation string based on nesting level
  8. proc indent {} {
  9. variable current_level
  10. return [string repeat " " $current_level]
  11. }
  12.  
  13. # Increment / decrement current indent level
  14. proc + {} { variable current_level; incr current_level }
  15. proc - {} { variable current_level; incr current_level -1 }
  16.  
  17. # Core generator functions
  18. proc _df {self name {arg ""}} {
  19. if {$self eq "s"} {
  20. return "def ${name}(self,${arg}):"
  21. } else {
  22. return "def ${name}(${arg}):"
  23. }
  24. }
  25.  
  26. proc _rt {arg} { return "return $arg" }
  27.  
  28. proc _de {self name {arg ""}} {
  29. if {$self eq "s"} {
  30. return "def ${name}(self,event=None,${arg}):"
  31. } else {
  32. return "def ${name}(event=None,${arg}):"
  33. }
  34. }
  35.  
  36. proc _fc {self func {arg ""} {param ""}} {
  37. switch -- $self {
  38. "s" { return "self.${func}(${arg})" }
  39. "z" { return "self.${func}(self.${arg})" }
  40. "k" { return "${func}(self.${arg})" }
  41. default { return "${func}(${arg})" }
  42. }
  43. }
  44.  
  45. proc _vf {scope name func {arg ""} {extra ""}} {
  46. set t_pref ""
  47. set f_pref ""
  48. set a_pref ""
  49.  
  50. if {$scope eq "s"} {
  51. set t_pref "self."
  52. } elseif {$scope eq "z"} {
  53. set t_pref "self."
  54. set f_pref "self."
  55. set a_pref "self."
  56.  
  57. } elseif {$scope eq "k"} {
  58. set f_pref "self."
  59.  
  60. } elseif {$scope eq "a"} {
  61. set f_pref "self."
  62. set a_pref "self."
  63.  
  64. } elseif {$scope eq "t"} {
  65. set t_pref "self."
  66. set f_pref "self."
  67. }
  68. set line "${t_pref}${name} = ${f_pref}${func}(${a_pref}${arg})"
  69. if {$extra ne ""} { append line " $extra" }
  70. return $line
  71. }
  72.  
  73. proc _va {self name val} {
  74. switch -- $self {
  75. "s" { return "self.$name = $val" }
  76. "k" { return "$name = self.$val" }
  77. "z" { return "self.$name = self.$val" }
  78. default { return "$name = $val" }
  79. }
  80. }
  81.  
  82. proc _wi {self func arg name} {
  83. if {$self eq "a"} {
  84. return "with ${func}(self.${arg}) as $name:"
  85. } elseif {$self eq "s"} {
  86. return "with self.${func}(${arg}) as $name:"
  87. } else {
  88. return "with ${func}(${arg}) as $name:"
  89. }
  90. }
  91.  
  92. proc _ytr {} { return "try:" }
  93. proc _exc {} { return "except Exception as e:" }
  94.  
  95. proc _ff {f val {p ""} {param ""}} {
  96. switch -- $f {
  97. "f" { return "if ${val}(${p}) $param:" }
  98. "s" { return "if self.${val} $p $param:" }
  99. "k" {
  100. if {$param ne ""} {
  101. return "if self.${val}(${p}) $param:"
  102. } else {
  103. return "if self.${val}(${p}):"
  104. }
  105. }
  106. default { return "if ${val} $p:" }
  107. }
  108. }
  109.  
  110. proc _ef {f val {p ""}} {
  111. if {$f eq "f"} {
  112. return "elif ${val}(${p}):"
  113. } else {
  114. return "elif ${val}:"
  115. }
  116. }
  117.  
  118. proc _el {} { return "else:" }
  119. proc _br {} { return "break" }
  120.  
  121. proc _fr {f i l {p ""}} {
  122. switch -- $f {
  123. "f" { return "for $i in ${l}(${p}):" }
  124. "k" { return "for $i in self.${l}(${p}):" }
  125. "s" { return "for $i in self.$l:" }
  126. default { return "for $i in $l:" }
  127. }
  128. }
  129.  
  130. proc _ac {self name cc} {
  131. switch -- $self {
  132. "s" { return "self.$name += $cc" }
  133. "z" { return "self.$name += self.$cc" }
  134. "k" { return "$name += self.$cc" }
  135. default { return "$name += $cc" }
  136. }
  137. }
  138.  
  139. proc _dc {self name cc} {
  140. switch -- $self {
  141. "s" { return "self.$name -= $cc" }
  142. "z" { return "self.$name -= self.$cc" }
  143. "k" { return "$name -= self.$cc" }
  144. default { return "$name -= $cc" }
  145. }
  146. }
  147. proc _fin {} { return "finally:" }
  148. proc _ps {} { return "pass" }
  149. proc _wh {cond} { return "while $cond:" }
  150. proc _cnt {} { return "continue" }
  151.  
  152. # Metaprogramming:
  153. #
  154. set commands {br df rt de fc vf va ff ef el fr ac dc wi ytr exc wh cnt fin ps}
  155.  
  156. foreach cmd $commands {
  157. proc ::ytcl::$cmd {args} \
  158. "puts -nonewline \[indent\]; puts \[eval _$cmd \$args\]"
  159. }
  160.  
  161. #generate $level$cmd procs for level 0..5
  162. #~ set commands {df rt de fc vf va ff ef el fr ac dc wi ytr exc wh cnt}
  163. #~ for {set i 0} {$i <= 5} {incr i} {
  164. #~ foreach cmd $commands {
  165. #~ # Create a proc like "0df", "1df", ...
  166. #~ proc ::ytcl::${i}${cmd} {args} [string map [list %i $i %cmd $cmd] {
  167. #~ variable indents
  168. #~ puts -nonewline [lindex $indents %i]
  169. #~ puts [eval _%cmd $args]
  170. #~ }]
  171. #~ }
  172. #~ }
  173.  
  174. # Toplevel global commands
  175. proc bang {} {
  176. puts "#!/usr/bin/env python3"
  177. puts "#!ytcl.tcl;"
  178. }
  179.  
  180. proc cl {name {base ""}} { puts "class ${name}(${base}):" }
  181. proc imp {pkg} { puts "import $pkg" }
  182. proc as {pkg alias} { puts "import $pkg as $alias" }
  183. proc frm {module name} { puts "from $module import $name" }
  184. proc mn {class windowTitle} {
  185. puts "if __name__ == '__main__':"
  186. puts " runIt = ${class}()"
  187. puts " runIt.title(\"$windowTitle\")"
  188. puts " runIt.mainloop()"
  189. }
  190.  
  191. ########################################################
  192. # keep these as an example of tcl power
  193. # cla class_name base1 base2
  194. proc cla {name args} {
  195. puts "class ${name}([join $args {, }]):"
  196. }
  197.  
  198. # dec decorator_name ’ @decorator_name
  199. # dec "decorator_name(args)" ’ @decorator_name(args) (pass as a single string)
  200. # dec decorator_name arg1 arg2 ’ @decorator_name(arg1, arg2)
  201. proc dec {name args} {
  202. if {[llength $args] == 0} {
  203. puts -nonewline [indent]
  204. puts "@$name"
  205. } else {
  206. # If the first extra argument looks like a parenthesis group, use it as is
  207. if {[string match "(*)" $args]} {
  208. puts -nonewline [indent]
  209. puts "@${name}$args"
  210. } else {
  211. puts -nonewline [indent]
  212. puts "@${name}([join $args {, }])"
  213. }
  214. }
  215. }
  216. #############################################
  217.  
  218. # cm "some text" ’ # some text
  219. proc cm {text} {
  220. puts -nonewline [indent]
  221. puts "# $text"
  222. }
  223.  
  224. proc doc {text} {
  225. puts -nonewline [indent]
  226. puts "\"\"\"${text}\"\"\""
  227. }
  228.  
  229. # Utilities
  230. proc bd {self widget pairs} {
  231. foreach {key handler} $pairs {
  232. fc $self ${widget}.bind "\"${key}\", self.${handler}"
  233. }
  234. }
  235. proc sf {empty index pattern} {
  236. va l $index {[(m.start(),m.end()) for m in finditer(r'$pattern', data)]}
  237. fr - start,end $index
  238. +
  239. fc s this_text_box.tag_add {"$index",f"1.0+{start}c",f"1.0+{end}c"}
  240. -
  241. }
  242. namespace export *
  243. }
  244.  
  245. namespace import ::ytcl::*
  246.  
  247. proc unknown {args} {
  248. puts -nonewline [::ytcl::indent]
  249. puts [join $args " "]
  250. }
  251.  
  252.  
  253.  
  254.  
  255.  

Add a comment

Please note that this site uses the meta tags nofollow,noindex for all pages that contain comments.
Items are closed for new comments after 1 week