Posted to tcl by colin at Wed Jan 05 07:00:03 GMT 2011view raw

  1. # zen - parse and manipulate zencode
  2.  
  3. package provide zen 1.0
  4.  
  5. if {[catch {package require Debug}]} {
  6. #proc Debug.zen {args} {}
  7. proc Debug.zen {args} {puts stderr zen@[uplevel subst $args]}
  8. } else {
  9. Debug define zen 10
  10. }
  11.  
  12. oo::class create Zen {
  13. method token {string {type wordchar}} {
  14. set failed 0
  15. set match [string is $type -strict -failindex failed $string]
  16. Debug.zen {token: string is $type until: $failed over '$string'}
  17. if {$match} {
  18. return [list $string ""] ;# whole string matches
  19. } elseif {$failed} {
  20. return [list [string range $string 0 $failed-1] [string range $string $failed end]]
  21. } else {
  22. return [list "" $string]
  23. }
  24. }
  25.  
  26. method tokenize {match_var rest_var {type wordchar}} {
  27. upvar 1 $match_var match
  28. upvar 1 $rest_var rest
  29.  
  30. lassign [my token $rest $type] match rest
  31. set match [string trim $match]
  32. set rest [string trim $rest]
  33.  
  34. Debug.zen {tokenize $type: '$match' '[string range $rest 0 10]'}
  35. return [expr {$match ne ""}]
  36. }
  37.  
  38. method punct {rest_var} {
  39. upvar 1 $rest_var rest
  40. set rest [string trim $rest]
  41. set punct [string index $rest 0]
  42. Debug.zen {is '$punct' punct?}
  43. if {$punct in {. # * \[ | > + (}} {
  44. set rest [string range $rest 1 end]
  45. Debug.zen {punct '$punct' '[string range $rest 0 10]'}
  46. return $punct
  47. } else {
  48. Debug.zen {punct failed over '$rest'}
  49. return ""
  50. }
  51. }
  52.  
  53. method upto {what match_var rest_var} {
  54. upvar 1 $match_var match
  55. upvar 1 $rest_var rest
  56.  
  57. set index [string first $what $rest]
  58. if {$index < 0} {
  59. # no match
  60. return 0
  61. } else {
  62. set match [string trim [string range $rest 0 $index-1]]
  63. set rest [string trim [string range $rest $index+1 end]]
  64. return 1
  65. }
  66. }
  67.  
  68. method compound {rest_var} {
  69. upvar 1 $rest_var rest
  70. set $rest [string trim $rest]
  71. Debug.zen {compound '$rest'}
  72. if {$rest eq ""} {
  73. return ""
  74. }
  75.  
  76. # look for leading punctuation
  77. set punct [my punct rest]
  78. Debug.zen {compound punct: '$punct'}
  79.  
  80. switch -- $punct {
  81. "" {
  82. error "Can't parse '$rest' - no copula or compound punctuation"
  83. }
  84. . {
  85. # class
  86. if {![my tokenize class rest]} {
  87. error "trailing '.' with no identifier"
  88. }
  89. return [list class $class]
  90. }
  91.  
  92. # {
  93. # id
  94. if {![my tokenize id rest]} {
  95. error "trailing '#' with no identifier"
  96. }
  97. return [list id $id]
  98. }
  99.  
  100. * {
  101. # multiplier
  102. if {[my tokenize mult rest integer]} {
  103. return [list mult $mult]
  104. } else {
  105. return [list mult ""]
  106. }
  107. }
  108.  
  109. \[ {
  110. # attribute
  111. if {[my upto \] match rest]} {
  112. return [list attr $match]
  113. } else {
  114. error "no matching \] parsing '$rest'"
  115. }
  116. }
  117.  
  118. | -
  119. > -
  120. + {
  121. # connector - not compound
  122. set rest ${punct}$rest
  123. return ""
  124. }
  125.  
  126. \( {
  127. error "misplaced '(' in $rest"
  128. }
  129. }
  130. }
  131.  
  132. method compounding {rest_var} {
  133. upvar 1 $rest_var rest
  134. set rest [string trim $rest]
  135.  
  136. Debug.zen {compounding '$rest'}
  137. if {$rest eq ""} {
  138. return ""
  139. }
  140.  
  141. set result {}
  142. while {1} {
  143. set compound [my compound rest]
  144. if {$compound eq ""} break
  145. lappend result {*}$compound
  146. }
  147.  
  148. Debug.zen {compounded '$result' remaining '$rest'}
  149. return $result
  150. }
  151.  
  152. method id {rest_var} {
  153. upvar 1 $rest_var rest
  154. set rest [string trim $rest]
  155. Debug.zen {looking for id in: '$rest'}
  156. if {$rest eq ""} {
  157. return ""
  158. }
  159.  
  160. # look for leading word
  161. my tokenize word rest
  162. if {$word ne ""} {
  163. Debug.zen {leading word: '$word'}
  164. set result [list word $word {*}[my compounding rest]]
  165. Debug.zen {id is: '$result' remaining: $rest}
  166. return $result
  167. } else {
  168. # look for id punctuation
  169. set punct [my punct rest]
  170. Debug.zen {id punct: '$punct'}
  171.  
  172. switch -- $punct {
  173. . {
  174. return [list default . {*}[my compounding rest]]
  175. }
  176. \# {
  177. return [list default \# {*}[my compounding rest]]
  178. }
  179.  
  180. * {
  181. return [list default * {*}[my compounding rest]]
  182. }
  183.  
  184. \( {
  185. return [my copula rest]
  186. }
  187.  
  188. > -
  189. + -
  190. \[ -
  191. \| {
  192. error "naked '$punct' in '$rest'. Expecting an identifier"
  193. }
  194.  
  195. default {
  196. error "unknown punctuation '$punct' in '$rest'"
  197. }
  198. }
  199. }
  200. }
  201.  
  202. # copula - having found an id/subexpr on the left,
  203. # find a copula (+,>) and an id on the right
  204. method copula {rest_var} {
  205. upvar 1 $rest_var rest
  206. set rest [string trim $rest]
  207. Debug.zen {looking for copula in '$rest'}
  208. if {$rest eq ""} {
  209. return ""
  210. }
  211.  
  212. # look for leading punctuation
  213. set punct [my punct rest]
  214. Debug.zen {copula punct: '$punct'}
  215. switch -- $punct {
  216. > {
  217. return child
  218. }
  219.  
  220. + {
  221. return sib
  222. }
  223.  
  224. default {
  225. error "unknown punctuation '$punct' in '$rest'"
  226. }
  227. }
  228. }
  229.  
  230. method parser {rest_var} {
  231. upvar 1 $rest_var rest
  232. set rest [string trim $rest]
  233. Debug.zen {parser over: rest: '$rest'}
  234. if {$rest eq ""} {
  235. return ""
  236. }
  237.  
  238. # get lhs id/phrase
  239. set result [list [my id rest]]
  240. Debug.zen {parse lhs: '$result', rest: '$rest'}
  241.  
  242. while {$rest ne ""} {
  243. Debug.zen {parse looking for copula in '$rest'}
  244. set copula [my copula rest]
  245. Debug.zen {parse copula: '$copula', rest: '$rest'}
  246.  
  247. switch -- $copula {
  248. child -
  249. sib {
  250. # get rhs id/phrase
  251. set rhs [my id rest]
  252. Debug.zen {parsed $copula rhs: '$rhs', rest: '$rest'}
  253.  
  254. lappend result $copula $rhs
  255. }
  256.  
  257. "" {
  258. Debug.zen {parsed: $result}
  259. return $result
  260. }
  261.  
  262. default {
  263. error "unknown copula '$copyla'"
  264. }
  265. }
  266. }
  267.  
  268. Debug.zen {completed: $result}
  269. return $result
  270. }
  271.  
  272. method parse {rest} {
  273. set result [my parser rest]
  274. Debug.zen {parse intermediate: '$result'}
  275. set cmd [list \[my generate]
  276. set level 1
  277. foreach {el op} $result {
  278. if {$op eq "child"} {
  279. if {[dict exists $el mult]} {
  280. set mult [dict get $el mult]
  281. dict unset el mult
  282. lappend cmd \[my child \[mult $mult \[my $el\]
  283. incr level
  284. } else {
  285. lappend cmd \[my child \[my $el\]
  286. }
  287. incr level
  288. } else {
  289. if {[dict exists $el mult]} {
  290. set mult [dict get $el mult]
  291. dict unset el mult
  292. lappend cmd \[my mult $mult \[my $el\]\]
  293. } else {
  294. lappend cmd \[my $el\]
  295. }
  296. }
  297. }
  298. set cmd [join $cmd]
  299. append cmd [string repeat \] $level]
  300. return $cmd
  301. }
  302.  
  303. destructor {}
  304. constructor {args} {
  305. variable {*}$args
  306. }
  307. }
  308.  
  309. if {[info exists argv0] && ($argv0 eq [info script])} {
  310. package require tcltest
  311. namespace import ::tcltest::*
  312.  
  313. variable SETUP {Zen create zen}
  314. variable CLEANUP {zen destroy}
  315.  
  316. test complex-1 {} -setup $SETUP -body {
  317. zen parse {div#page>div.logo+ul#navigation>li*5>a}
  318. } -cleanup $CLEANUP -result {[my generate [my child [my word div id page] [my word div class logo] [my child [my word ul id navigation] [my child [mult 5 [my word li] [my word a]]]]]]}
  319.  
  320. set count 0
  321. foreach {from to} {
  322. div#name {[my generate [my word div id name]]}
  323. div.class {[my generate [my word div class class]]}
  324. div.one.two {[my generate [my word div class one class two]]}
  325. div#name.one.two {[my generate [my word div id name class one class two]]}
  326. head>link {[my generate [my child [my word head] [my word link]]]}
  327. table>tr>td {[my generate [my child [my word table] [my child [my word tr] [my word td]]]]}
  328. ul#name>li.item {[my generate [my child [my word ul id name] [my word li class item]]]}
  329. p+p {[my generate [my word p] [my word p]]}
  330. div#name>p.one+p.two {[my generate [my child [my word div id name] [my word p class one] [my word p class two]]]}
  331. p[title] {[my generate [my word p attr title]]}
  332. td[colspan=2] {[my generate [my word td attr colspan=2]]}
  333. {span[title="Hello" rel]} {[my generate [my word span attr {title="Hello" rel}]]}
  334. p.title|e .
  335. p*3 {[my generate [my mult 3 [my word p]]]}
  336. ul#name>li.item*3 {[my generate [my child [my word ul id name] [my mult 3 [my word li class item]]]]}
  337. p.name-$*3 .
  338. select>option#item-$*3 .
  339. ul+ .
  340. table+ .
  341. } {
  342. incr count
  343. test simple-$count {} -setup $SETUP -body [list zen parse $from] -cleanup $CLEANUP -result $to
  344. }
  345.  
  346. # To see test statistics (Total/Passed/Skipped/Failed), best put this line in the end:
  347. cleanupTests
  348. }