commit f1c767551aea0eed2bc7ea1793e50327d10bd224 parent 048e816f0c685e6b22656c50fa4e53bad025ed08 Author: Yuval Langer <yuval.langer@gmail.com> Date: Sat, 15 Jun 2024 01:47:21 +0300 Take definitions out of the big weird letrec. Diffstat:
| M | pstk.scm | | | 1373 | +++++++++++++++++++++++++++++++++++++++---------------------------------------- |
1 file changed, 682 insertions(+), 691 deletions(-)
diff --git a/pstk.scm b/pstk.scm @@ -245,697 +245,688 @@ (display x out) (get-output-string out)))))) -(letrec - ((nl (string #\newline)) - (wish-input #f) - (wish-output #f) - (tk-is-running #f) - (tk-ids+widgets '()) - (tk-widgets '()) - (commands-invoked-by-tk '()) - (inverse-commands-invoked-by-tk '()) - (in-callback #f) - (callback-mutex #t) - (ttk-widget-map '()) - (tk-init-string - (apply string-append - (apply append - (map (lambda (s) - (list s (string #\newline))) - '("package require Tk" - "if {[package version tile] != \"\"} {" - " package require tile" - "}" - "" - "namespace eval AutoName {" - " variable c 0" - " proc autoName {{result \\#\\#}} {" - " variable c" - " append result [incr c]" - " }" - " namespace export *" - "}" - "" - "namespace import AutoName::*" - "" - "proc callToScm {callKey args} {" - " global scmVar" - " if { [catch {" - " set resultKey [autoName]" - " puts \"(call $callKey \\\"$resultKey\\\" $args)\"" - " flush stdout" - " vwait scmVar($resultKey)" - " set result $scmVar($resultKey)" - " unset scmVar($resultKey)" - " set result" - " } ]" - " } { exit 1 }" - "}" - "" - "proc tclListToScmList {l} {" - " switch [llength $l] {" - " 0 {" - " return ()" - " }" - " 1 {" - " if {[string range $l 0 0] eq \"\\#\"} {" - " return $l" - " }" - " if {[regexp {^[0-9]+$} $l]} {" - " return $l" - " }" - " if {[regexp {^[.[:alpha:]][^ ,\\\"\\'\\[\\]\\\\;]*$} $l]} {" - " return $l" - " }" - " set result \\\"" - " append result\\" - " [string map [list \\\" \\\\\\\" \\\\ \\\\\\\\] $l]" - " append result \\\"" - "" - " }" - " default {" - " set result {}" - " foreach el $l {" - " append result \" \" [tclListToScmList $el]" - " }" - " set result [string range $result 1 end]" - " return \"($result)\"" - " }" - " }" - "}" - "" - "proc evalCmdFromScm {cmd {properly 0}} {" - " if {[catch {" - " set result [uplevel \\#0 $cmd]" - " } err]} {" - " puts \"(error \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $err]\\\")\"" - " } elseif $properly {" - " puts \"(return [tclListToScmList $result])\"" - " } else {" - " puts \"(return \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $result]\\\")\"" - " }" - " flush stdout" - "}"))))) - - (report-error - (lambda (x) - (newline) - (display x) - (newline) - (when (tk-throw) - (error 'tk (->string x))))) - - (run-program - (lambda (program) - (letrec - ((open-i/o-process - (lambda (prog . args) - (let ((c2p (pipe)) - (p2c (pipe))) - (setvbuf (cdr c2p) 'none) - (setvbuf (cdr p2c) 'none) - (let ((pid (primitive-fork))) - (cond ((= pid 0) - (ensure-batch-mode!) - (let ((input-fdes (fileno (car p2c))) - (output-fdes (fileno (cdr c2p)))) - (port-for-each - (lambda (pt-entry) - (false-if-exception - (let ((pt-fileno (fileno pt-entry))) - (if (not (or (= pt-fileno input-fdes) - (= pt-fileno output-fdes))) - (close-fdes pt-fileno)))))) - (cond ((not (= input-fdes 0)) - (if (= output-fdes 0) - (set! output-fdes (dup->fdes 0))) - (dup2 input-fdes 0))) - (if (not (= output-fdes 1)) - (dup2 output-fdes 1)) - (apply execlp prog prog args))) - (else - (close-port (cdr c2p)) - (close-port (car p2c)) - (cons (car c2p) - (cdr p2c))))))))) - (let* ((in/out - (open-i/o-process "/bin/sh" "-c" - (string-append "exec " program))) - (in (car in/out)) - (out (cdr in/out))) - (list in out))))) - - (flush-output-port force-output) - - (flush-wish +;;; Start weird letrec definitions: + +(define nl (string #\newline)) +(define wish-input #f) +(define wish-output #f) +(define tk-is-running #f) +(define tk-ids+widgets '()) +(define tk-widgets '()) +(define commands-invoked-by-tk '()) +(define inverse-commands-invoked-by-tk '()) +(define in-callback #f) +(define callback-mutex #t) +(define ttk-widget-map '()) +(define tk-init-string + (apply string-append + (apply append + (map (lambda (s) + (list s (string #\newline))) + '("package require Tk" + "if {[package version tile] != \"\"} {" + " package require tile" + "}" + "" + "namespace eval AutoName {" + " variable c 0" + " proc autoName {{result \\#\\#}} {" + " variable c" + " append result [incr c]" + " }" + " namespace export *" + "}" + "" + "namespace import AutoName::*" + "" + "proc callToScm {callKey args} {" + " global scmVar" + " if { [catch {" + " set resultKey [autoName]" + " puts \"(call $callKey \\\"$resultKey\\\" $args)\"" + " flush stdout" + " vwait scmVar($resultKey)" + " set result $scmVar($resultKey)" + " unset scmVar($resultKey)" + " set result" + " } ]" + " } { exit 1 }" + "}" + "" + "proc tclListToScmList {l} {" + " switch [llength $l] {" + " 0 {" + " return ()" + " }" + " 1 {" + " if {[string range $l 0 0] eq \"\\#\"} {" + " return $l" + " }" + " if {[regexp {^[0-9]+$} $l]} {" + " return $l" + " }" + " if {[regexp {^[.[:alpha:]][^ ,\\\"\\'\\[\\]\\\\;]*$} $l]} {" + " return $l" + " }" + " set result \\\"" + " append result\\" + " [string map [list \\\" \\\\\\\" \\\\ \\\\\\\\] $l]" + " append result \\\"" + "" + " }" + " default {" + " set result {}" + " foreach el $l {" + " append result \" \" [tclListToScmList $el]" + " }" + " set result [string range $result 1 end]" + " return \"($result)\"" + " }" + " }" + "}" + "" + "proc evalCmdFromScm {cmd {properly 0}} {" + " if {[catch {" + " set result [uplevel \\#0 $cmd]" + " } err]} {" + " puts \"(error \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $err]\\\")\"" + " } elseif $properly {" + " puts \"(return [tclListToScmList $result])\"" + " } else {" + " puts \"(return \\\"[string map [list \\\\ \\\\\\\\ \\\" \\\\\\\"] $result]\\\")\"" + " }" + " flush stdout" + "}"))))) + +(define (report-error x) + (newline) + (display x) + (newline) + (when (tk-throw) + (error 'tk (->string x)))) + +(define (run-program program) + (define (open-i/o-process prog .args) + (let ((c2p (pipe)) + (p2c (pipe))) + (setvbuf (cdr c2p) 'none) + (setvbuf (cdr p2c) 'none) + (let ((pid (primitive-fork))) + (cond ((= pid 0) + (ensure-batch-mode!) + (let ((input-fdes (fileno (car p2c))) + (output-fdes (fileno (cdr c2p)))) + (port-for-each + (lambda (pt-entry) + (false-if-exception + (let ((pt-fileno (fileno pt-entry))) + (if (not (or (= pt-fileno input-fdes) + (= pt-fileno output-fdes))) + (close-fdes pt-fileno)))))) + (cond ((not (= input-fdes 0)) + (if (= output-fdes 0) + (set! output-fdes (dup->fdes 0))) + (dup2 input-fdes 0))) + (if (not (= output-fdes 1)) + (dup2 output-fdes 1)) + (apply execlp prog prog args))) + (else + (close-port (cdr c2p)) + (close-port (car p2c)) + (cons (car c2p) + (cdr p2c))))))) + + (let* ((in/out + (open-i/o-process "/bin/sh" "-c" + (string-append "exec " program))) + (in (car in/out)) + (out (cdr in/out))) + (list in out))) + +(define flush-output-port force-output) + +(define flush-wish + (lambda () + (flush-output-port wish-input))) + +(define option? + (lambda (x) + (or (and *use-keywords?* + (keyword? x)) + (and (symbol? x) + (let* ((s (symbol->string x)) + (n (string-length s))) + (char=? #\: (string-ref s (- n 1)))))))) + +(define make-option-string + (lambda (x) + (if (and *use-keywords?* + (keyword? x)) + (string-append " -" (keyword->string x)) + (let ((s (symbol->string x))) + (string-append " -" + (substring s 0 (- (string-length s) 1))))))) + +(define (improper-list->string a first) + (cond ((pair? a) + (cons (string-append (if first "" " ") + (form->string (car a))) + (improper-list->string (cdr a) #f))) + ((null? a) '()) + (else (list (string-append " . " (form->string a)))))) + +(define (form->string x) + (cond ((eq? #t x) "#t") + ((eq? #f x) "#f") + ((number? x) (number->string x)) + ((symbol? x) (symbol->string x)) + ((string? x) x) + ((null? x) "()") + ((pair? x) + (string-append "(" + (apply string-append + (improper-list->string x #t)) + ")")) + ((eof-object? x) "#<eof>") + (else "#<other>"))) + +(define (string-translate s map) + (letrec + ((s-prepend (lambda (s1 s2) + (cond ((null? s1) s2) + (else (s-prepend (cdr s1) (cons (car s1) s2)))))) + (s-xlate (lambda (s r) + (cond ((null? s) (reverse r)) + (else (let ((n (assv (car s) map))) + (cond (n (s-xlate (cdr s) + (s-prepend (string->list (cdr n)) r))) + (else (s-xlate (cdr s) + (cons (car s) r)))))))))) + (list->string + (s-xlate (string->list s) '())))) + +(define (string-trim-left str) + (cond ((string=? str "") "") + ((string=? (substring str 0 1) " ") + (string-trim-left (substring str 1 + (string-length str)))) + (else str))) + +(define (get-property key args . thunk) + (cond ((null? args) + (cond ((null? thunk) #f) + (else ((car thunk))))) + ((eq? key (car args)) + (cond ((pair? (cdr args)) (cadr args)) + (else (report-error (list 'get-property key args))))) + ((or (not (pair? (cdr args))) + (not (pair? (cddr args)))) + (report-error (list 'get-property key args))) + (else (apply get-property key (cddr args) thunk)))) + +(define tcl-true? + (let ((false-values + `(0 "0" 'false "false" ,(string->symbol "0")))) + (lambda (obj) (not (memv obj false-values))))) + +(define (widget? x) + (and (memq x tk-widgets) #t)) + +(define (call-by-key key resultvar . args) + (cond ((and in-callback (pair? callback-mutex)) #f) + (else (set! in-callback (cons #t in-callback)) + (let* ((cmd (get-property key commands-invoked-by-tk)) + (result (apply cmd args)) + (str (string-trim-left + (scheme-arglist->tk-argstring + (list result))))) + (set-var! resultvar str) + (set! in-callback (cdr in-callback)) + result)))) + +(define gen-symbol + (let ((counter 0)) (lambda () - (flush-output-port wish-input))) - - (option? - (lambda (x) - (or (and *use-keywords?* - (keyword? x)) - (and (symbol? x) - (let* ((s (symbol->string x)) - (n (string-length s))) - (char=? #\: (string-ref s (- n 1)))))))) - - (make-option-string - (lambda (x) - (if (and *use-keywords?* - (keyword? x)) - (string-append " -" (keyword->string x)) - (let ((s (symbol->string x))) - (string-append " -" - (substring s 0 (- (string-length s) 1))))))) - - (improper-list->string - (lambda (a first) - (cond ((pair? a) - (cons (string-append (if first "" " ") - (form->string (car a))) - (improper-list->string (cdr a) #f))) - ((null? a) '()) - (else (list (string-append " . " (form->string a))))))) - - (form->string - (lambda (x) - (cond ((eq? #t x) "#t") - ((eq? #f x) "#f") - ((number? x) (number->string x)) - ((symbol? x) (symbol->string x)) - ((string? x) x) - ((null? x) "()") - ((pair? x) - (string-append "(" - (apply string-append - (improper-list->string x #t)) - ")")) - ((eof-object? x) "#<eof>") - (else "#<other>")))) - - (string-translate - (lambda (s map) - (letrec - ((s-prepend (lambda (s1 s2) - (cond ((null? s1) s2) - (else (s-prepend (cdr s1) (cons (car s1) s2)))))) - (s-xlate (lambda (s r) - (cond ((null? s) (reverse r)) - (else (let ((n (assv (car s) map))) - (cond (n (s-xlate (cdr s) - (s-prepend (string->list (cdr n)) r))) - (else (s-xlate (cdr s) - (cons (car s) r)))))))))) - (list->string - (s-xlate (string->list s) '()))))) - - (string-trim-left - (lambda (str) - (cond ((string=? str "") "") - ((string=? (substring str 0 1) " ") - (string-trim-left (substring str 1 - (string-length str)))) - (else str)))) - - (get-property - (lambda (key args . thunk) - (cond ((null? args) - (cond ((null? thunk) #f) - (else ((car thunk))))) - ((eq? key (car args)) - (cond ((pair? (cdr args)) (cadr args)) - (else (report-error (list 'get-property key args))))) - ((or (not (pair? (cdr args))) - (not (pair? (cddr args)))) - (report-error (list 'get-property key args))) - (else (apply get-property key (cddr args) thunk))))) - - (tcl-true? - (let ((false-values - `(0 "0" 'false "false" ,(string->symbol "0")))) - (lambda (obj) (not (memv obj false-values))))) - - (widget? - (lambda (x) - (and (memq x tk-widgets) #t))) - - (call-by-key - (lambda (key resultvar . args) - (cond ((and in-callback (pair? callback-mutex)) #f) - (else (set! in-callback (cons #t in-callback)) - (let* ((cmd (get-property key commands-invoked-by-tk)) - (result (apply cmd args)) - (str (string-trim-left - (scheme-arglist->tk-argstring - (list result))))) - (set-var! resultvar str) - (set! in-callback (cdr in-callback)) - result))))) - - (gen-symbol - (let ((counter 0)) - (lambda () - (let ((sym (string-append "g" (number->string counter)))) - (set! counter (+ counter 1)) - (string->symbol sym))))) - - (widget-name - (lambda (x) - (let ((name (form->string x))) - (cond ((member name ttk-widget-map) - (string-append "ttk::" name)) - (else name))))) - - (make-widget-by-id - (lambda (type id . options) - (let - ((result - (lambda (command . args) - (case command - ((get-id) id) - ((create-widget) - (let* ((widget-type (widget-name (car args))) - (id-prefix (if (string=? id ".") "" id)) - (id-suffix (form->string (gen-symbol))) - (new-id (string-append id-prefix "." id-suffix)) - (options (cdr args))) - (eval-wish - (string-append - widget-type - " " - new-id - (scheme-arglist->tk-argstring options))) - (apply make-widget-by-id - (append (list widget-type new-id) - options)))) - ((configure) - (cond ((null? args) - (eval-wish - (string-append id " " (form->string command)))) - ((null? (cdr args)) - (eval-wish - (string-append - id - " " - (form->string command) - (scheme-arglist->tk-argstring args)))) - (else - (eval-wish - (string-append - id - " " - (form->string command) - (scheme-arglist->tk-argstring args))) - (do ((args args (cddr args))) - ((null? args) '()) - (let ((key (car args)) (val (cadr args))) - (cond ((null? options) - (set! options (list key val))) - ((not (memq key options)) - (set! options - (cons key (cons val options)))) - (else (set-car! (cdr (memq key options)) - val)))))))) - ((cget) - (let ((key (car args))) - (get-property - key - options - (lambda () - (eval-wish - (string-append - id - " cget" - (scheme-arglist->tk-argstring args))))))) - ((call exec) - (eval-wish - (string-trim-left - (scheme-arglist->tk-argstring args)))) - (else - (eval-wish - (string-append - id - " " - (form->string command) - (scheme-arglist->tk-argstring args)))))))) - (set! tk-widgets (cons result tk-widgets)) - (set! tk-ids+widgets - (cons (string->symbol id) - (cons result tk-ids+widgets))) - result))) - - (scheme-arg->tk-arg - (lambda (x) - (cond ((eq? x #f) " 0") - ((eq? x #t) " 1") - ((eq? x '()) " {}") - ((option? x) (make-option-string x)) - ((widget? x) (string-append " " (x 'get-id))) - ((and (pair? x) (procedure? (car x))) - (let* ((lambda-term (car x)) - (rest (cdr x)) - (l (memq lambda-term - inverse-commands-invoked-by-tk)) - (keystr (if l (form->string (cadr l)) - (symbol->string (gen-symbol))))) - (if (not l) - (let ((key (string->symbol keystr))) - (set! inverse-commands-invoked-by-tk - (cons lambda-term - (cons key - inverse-commands-invoked-by-tk))) - (set! commands-invoked-by-tk - (cons key - (cons lambda-term - commands-invoked-by-tk))))) - (string-append " {callToScm " - keystr - (scheme-arglist->tk-argstring rest) - "}"))) - ((procedure? x) - (scheme-arglist->tk-argstring `((,x)))) - ((list? x) - (cond ((eq? (car x) '+) - (let ((result (string-trim-left - (scheme-arglist->tk-argstring - (cdr x))))) - (cond ((string=? result "") " +") - ((string=? "{" (substring result 0 1)) - (string-append - " {+ " - (substring result 1 - (string-length result)))) - (else (string-append " +" result))))) - ((and (= (length x) 3) - (equal? (car x) (string->symbol "@")) - (number? (cadr x)) - (number? (caddr x))) - (string-append - "@" - (number->string (cadr x)) - "," - (number->string (caddr x)))) + (let ((sym (string-append "g" (number->string counter)))) + (set! counter (+ counter 1)) + (string->symbol sym))))) + +(define (widget-name x) + (let ((name (form->string x))) + (cond ((member name ttk-widget-map) + (string-append "ttk::" name)) + (else name)))) + +(define (make-widget-by-id type id . options) + (let + ((result + (lambda (command . args) + (case command + ((get-id) id) + ((create-widget) + (let* ((widget-type (widget-name (car args))) + (id-prefix (if (string=? id ".") "" id)) + (id-suffix (form->string (gen-symbol))) + (new-id (string-append id-prefix "." id-suffix)) + (options (cdr args))) + (eval-wish + (string-append + widget-type + " " + new-id + (scheme-arglist->tk-argstring options))) + (apply make-widget-by-id + (append (list widget-type new-id) + options)))) + ((configure) + (cond ((null? args) + (eval-wish + (string-append id " " (form->string command)))) + ((null? (cdr args)) + (eval-wish + (string-append + id + " " + (form->string command) + (scheme-arglist->tk-argstring args)))) (else - (string-append - " {" - (string-trim-left - (scheme-arglist->tk-argstring x)) - "}")))) - ((pair? x) - (string-append - " " - (form->string (car x)) - "." - (form->string (cdr x)))) - ((string? x) - (if (string->number x) - (string-append " " x) - (string-append - " \"" - (string-translate x - '((#\\ . "\\\\") (#\" . "\\\"") - (#\[ . "\\u005b") (#\] . "\\]") - (#\$ . "\\u0024") - (#\{ . "\\{") (#\} . "\\}"))) - "\""))) - (else (string-append " " (form->string x)))))) - - (scheme-arglist->tk-argstring - (lambda (args) - (apply string-append - (map scheme-arg->tk-arg - args)))) - - (make-wish-func - (lambda (tkname) - (let ((name (form->string tkname))) - (lambda args - (eval-wish - (string-append - name - (scheme-arglist->tk-argstring args))))))) - - (read-wish - (lambda () - (let ((term (read wish-output))) - (cond (*wish-debug-output* - (display "wish->scheme: ") - (write term) - (newline))) - term))) - - (wish - (lambda arguments - (for-each - (lambda (argument) - (cond (*wish-debug-input* - (display "scheme->wish: ") - (display argument) - (newline))) - (display argument wish-input) - (newline wish-input) - (flush-wish)) - arguments))) - - (start-wish - (lambda () - (let ((result (run-program *wish-program*))) - (set! wish-input (cadr result)) - (set! wish-output (car result))))) - - (read-line - (lambda (in) - (letrec - ((collect-chars - (lambda (c s) - (cond ((or (eof-object? c) (char=? c #\newline)) - (apply string (reverse s))) - (else (collect-chars (read-char in) (cons c s)))))) - (first-char - (read-char in))) - (cond ((eof-object? first-char) first-char) - (else (collect-chars first-char '())))))) - - (eval-wish - (lambda (cmd) - (wish (string-append - "evalCmdFromScm \"" - (string-translate cmd - '((#\\ . "\\\\") (#\" . "\\\""))) - "\"")) - (let again ((result (read-wish))) - (cond ((not (pair? result)) - (report-error (string-append - "An error occurred inside Tcl/Tk" nl - " --> " (form->string result) - " " (read-line wish-output)))) - ((eq? (car result) 'return) - (cadr result)) - ((eq? (car result) 'call) - (apply call-by-key (cdr result)) - (again (read-wish))) - ((eq? (car result) 'error) - (report-error (string-append - "An error occurred inside Tcl/Tk" nl - " " cmd nl - " --> " (cadr result)))) - (else (report-error result)))))) - - (id->widget - (lambda (id) - (get-property - (string->symbol (form->string id)) - tk-ids+widgets - (lambda () - (if (tcl-true? (tk/winfo 'exists id)) - (make-widget-by-id - (tk/winfo 'class id) - (form->string id)) - #f))))) - - (var - (lambda (varname) - (set-var! varname "") - (string-append - "::scmVar(" - (form->string varname) - ")"))) - - (get-var - (lambda (varname) - (eval-wish - (string-append - "set ::scmVar(" - (form->string varname) - ")")))) - - (set-var! - (lambda (varname value) - (eval-wish - (string-append - "set ::scmVar(" - (form->string varname) - ") {" - (form->string value) - "}")))) - - (start - (lambda () - (start-wish) - (wish tk-init-string) - (set! tk-ids+widgets '()) - (set! tk-widgets '()) - (set! in-callback #f) - (set! tk (make-widget-by-id 'toplevel "." 'class: 'Wish)) - (set! commands-invoked-by-tk '()) - (set! inverse-commands-invoked-by-tk '()) - (tk/wm 'protocol tk 'WM_DELETE_WINDOW end-tk))) - - (end-tk - (lambda () - (set! tk-is-running #f) - (wish "after 200 exit"))) - - (dispatch-event - (lambda () - (let ((tk-statement (read-wish))) - (if (and (list? tk-statement) - (eq? (car tk-statement) 'call)) - (apply call-by-key (cdr tk-statement)))))) - - (loop - (lambda () - (cond ((not tk-is-running) - (if wish-output - (tk/wm 'protocol tk 'WM_DELETE_WINDOW '()))) - (else (dispatch-event) - (loop))))) - - (event-loop - (lambda () - (set! tk-is-running #t) - (loop))) - - (map-ttk-widgets - (lambda (x) - (cond ((eq? x 'all) - (set! ttk-widget-map '("button" "checkbutton" "radiobutton" - "menubutton" "label" "entry" "frame" - "labelframe" "scrollbar" "notebook" - "progressbar" "combobox" "separator" - "scale" "sizegrip" "treeview"))) - ((eq? x 'none) - (set! ttk-widget-map '())) - ((pair? x) (set! ttk-widget-map - (map form->string x))) - (else (report-error + (eval-wish + (string-append + id + " " + (form->string command) + (scheme-arglist->tk-argstring args))) + (do ((args args (cddr args))) + ((null? args) '()) + (let ((key (car args)) (val (cadr args))) + (cond ((null? options) + (set! options (list key val))) + ((not (memq key options)) + (set! options + (cons key (cons val options)))) + (else (set-car! (cdr (memq key options)) + val)))))))) + ((cget) + (let ((key (car args))) + (get-property + key + options + (lambda () + (eval-wish (string-append - "Argument to TTK-MAP-WIDGETS must be " - "ALL, NONE or a list of widget types.")))))) - - (string-split - (lambda (c s) - (letrec - ((split (lambda (i k tmp res) - (cond ((= i k) - (if (null? tmp) res (cons tmp res))) - ((char=? (string-ref s i) c) - (split (+ i 1) k "" (cons tmp res))) - (else (split (+ i 1) k - (string-append tmp - (string (string-ref s i))) - res)))))) - (reverse (split 0 (string-length s) "" '()))))) - - (ttk-available-themes - (lambda () - (string-split #\space (eval-wish "ttk::style theme names")))) - - (do-wait-for-window - (lambda (w) - (dispatch-event) - (cond ((equal? (tk/winfo 'exists w) "0") '()) - (else (do-wait-for-window w))))) - - (wait-for-window - (lambda (w) - (let ((outer-allow callback-mutex)) - (set! callback-mutex #t) - (do-wait-for-window w) - (set! callback-mutex outer-allow)))) - - (wait-until-visible - (lambda (w) - (tk/wait 'visibility w))) - - (lock! - (lambda () - (set! callback-mutex - (cons callback-mutex #t)))) - - (unlock! - (lambda () - (if (pair? callback-mutex) - (set! callback-mutex - (cdr callback-mutex))))) - - (with-lock - (lambda (thunk) - (lock!) - (thunk) - (unlock!)))) - - (set! tk-eval eval-wish) - (set! tk-id->widget id->widget) - (set! tk-var var) - (set! tk-get-var get-var) - (set! tk-set-var! set-var!) - (set! tk-start start) - (set! tk-end end-tk) - (set! tk-dispatch-event dispatch-event) - (set! tk-event-loop event-loop) - (set! tk-wait-for-window wait-for-window) - (set! tk-wait-until-visible wait-until-visible) - (set! tk-with-lock with-lock) - (set! tk/after (make-wish-func 'after)) - (set! tk/bell (make-wish-func 'bell)) - (set! tk/update (make-wish-func 'update)) - (set! tk/clipboard (make-wish-func 'clipboard)) - (set! tk/bgerror (make-wish-func 'bgerror)) - (set! tk/bind (make-wish-func 'bind)) - (set! tk/bindtags (make-wish-func 'bindtags)) - (set! tk/destroy (make-wish-func 'destroy)) - (set! tk/event (make-wish-func 'event)) - (set! tk/focus (make-wish-func 'focus)) - (set! tk/grab (make-wish-func 'grab)) - (set! tk/grid (make-wish-func 'grid)) - (set! tk/image (make-wish-func 'image)) - (set! tk/lower (make-wish-func 'lower)) - (set! tk/option (make-wish-func 'option)) - (set! tk/pack (make-wish-func 'pack)) - (set! tk/place (make-wish-func 'place)) - (set! tk/raise (make-wish-func 'raise)) - (set! tk/selection (make-wish-func 'selection)) - (set! tk/winfo (make-wish-func 'winfo)) - (set! tk/wm (make-wish-func 'wm)) - (set! tk/choose-color (make-wish-func "tk_chooseColor")) - (set! tk/choose-directory (make-wish-func "tk_chooseDirectory")) - (set! tk/dialog (make-wish-func "tk_dialog")) - (set! tk/get-open-file (make-wish-func "tk_getOpenFile")) - (set! tk/get-save-file (make-wish-func "tk_getSaveFile")) - (set! tk/message-box (make-wish-func "tk_messageBox")) - (set! tk/focus-follows-mouse (make-wish-func "tk_focusFollowsMouse")) - (set! tk/focus-next (make-wish-func "tk_focusNext")) - (set! tk/focus-prev (make-wish-func "tk_focusPrev")) - (set! tk/popup (make-wish-func "tk_popup")) - (set! tk/wait (lambda args (make-wish-func 'tkwait))) - (set! tk/appname (make-wish-func "tk appname")) - (set! tk/caret (make-wish-func "tk caret")) - (set! tk/scaling (make-wish-func "tk scaling")) - (set! tk/useinputmethods (make-wish-func "tk useinputmethods")) - (set! tk/windowingsystem (make-wish-func "tk windowingsystem")) - (set! ttk/available-themes ttk-available-themes) - (set! ttk/set-theme (make-wish-func "ttk::style theme use")) - (set! ttk/style (make-wish-func "ttk::style")) - (set! ttk-map-widgets map-ttk-widgets)) + id + " cget" + (scheme-arglist->tk-argstring args))))))) + ((call exec) + (eval-wish + (string-trim-left + (scheme-arglist->tk-argstring args)))) + (else + (eval-wish + (string-append + id + " " + (form->string command) + (scheme-arglist->tk-argstring args)))))))) + (set! tk-widgets (cons result tk-widgets)) + (set! tk-ids+widgets + (cons (string->symbol id) + (cons result tk-ids+widgets))) + result)) + +(define scheme-arg->tk-arg + (lambda (x) + (cond ((eq? x #f) " 0") + ((eq? x #t) " 1") + ((eq? x '()) " {}") + ((option? x) (make-option-string x)) + ((widget? x) (string-append " " (x 'get-id))) + ((and (pair? x) (procedure? (car x))) + (let* ((lambda-term (car x)) + (rest (cdr x)) + (l (memq lambda-term + inverse-commands-invoked-by-tk)) + (keystr (if l (form->string (cadr l)) + (symbol->string (gen-symbol))))) + (if (not l) + (let ((key (string->symbol keystr))) + (set! inverse-commands-invoked-by-tk + (cons lambda-term + (cons key + inverse-commands-invoked-by-tk))) + (set! commands-invoked-by-tk + (cons key + (cons lambda-term + commands-invoked-by-tk))))) + (string-append " {callToScm " + keystr + (scheme-arglist->tk-argstring rest) + "}"))) + ((procedure? x) + (scheme-arglist->tk-argstring `((,x)))) + ((list? x) + (cond ((eq? (car x) '+) + (let ((result (string-trim-left + (scheme-arglist->tk-argstring + (cdr x))))) + (cond ((string=? result "") " +") + ((string=? "{" (substring result 0 1)) + (string-append + " {+ " + (substring result 1 + (string-length result)))) + (else (string-append " +" result))))) + ((and (= (length x) 3) + (equal? (car x) (string->symbol "@")) + (number? (cadr x)) + (number? (caddr x))) + (string-append + "@" + (number->string (cadr x)) + "," + (number->string (caddr x)))) + (else + (string-append + " {" + (string-trim-left + (scheme-arglist->tk-argstring x)) + "}")))) + ((pair? x) + (string-append + " " + (form->string (car x)) + "." + (form->string (cdr x)))) + ((string? x) + (if (string->number x) + (string-append " " x) + (string-append + " \"" + (string-translate x + '((#\\ . "\\\\") (#\" . "\\\"") + (#\[ . "\\u005b") (#\] . "\\]") + (#\$ . "\\u0024") + (#\{ . "\\{") (#\} . "\\}"))) + "\""))) + (else (string-append " " (form->string x)))))) + +(define scheme-arglist->tk-argstring + (lambda (args) + (apply string-append + (map scheme-arg->tk-arg + args)))) + +(define make-wish-func + (lambda (tkname) + (let ((name (form->string tkname))) + (lambda args + (eval-wish + (string-append + name + (scheme-arglist->tk-argstring args))))))) + +(define read-wish + (lambda () + (let ((term (read wish-output))) + (cond (*wish-debug-output* + (display "wish->scheme: ") + (write term) + (newline))) + term))) + +(define wish + (lambda arguments + (for-each + (lambda (argument) + (cond (*wish-debug-input* + (display "scheme->wish: ") + (display argument) + (newline))) + (display argument wish-input) + (newline wish-input) + (flush-wish)) + arguments))) + +(define start-wish + (lambda () + (let ((result (run-program *wish-program*))) + (set! wish-input (cadr result)) + (set! wish-output (car result))))) + +(define read-line + (lambda (in) + (letrec + ((collect-chars + (lambda (c s) + (cond ((or (eof-object? c) (char=? c #\newline)) + (apply string (reverse s))) + (else (collect-chars (read-char in) (cons c s)))))) + (first-char + (read-char in))) + (cond ((eof-object? first-char) first-char) + (else (collect-chars first-char '())))))) + +(define eval-wish + (lambda (cmd) + (wish (string-append + "evalCmdFromScm \"" + (string-translate cmd + '((#\\ . "\\\\") (#\" . "\\\""))) + "\"")) + (let again ((result (read-wish))) + (cond ((not (pair? result)) + (report-error (string-append + "An error occurred inside Tcl/Tk" nl + " --> " (form->string result) + " " (read-line wish-output)))) + ((eq? (car result) 'return) + (cadr result)) + ((eq? (car result) 'call) + (apply call-by-key (cdr result)) + (again (read-wish))) + ((eq? (car result) 'error) + (report-error (string-append + "An error occurred inside Tcl/Tk" nl + " " cmd nl + " --> " (cadr result)))) + (else (report-error result)))))) + +(define id->widget + (lambda (id) + (get-property + (string->symbol (form->string id)) + tk-ids+widgets + (lambda () + (if (tcl-true? (tk/winfo 'exists id)) + (make-widget-by-id + (tk/winfo 'class id) + (form->string id)) + #f))))) + +(define var + (lambda (varname) + (set-var! varname "") + (string-append + "::scmVar(" + (form->string varname) + ")"))) + +(define get-var + (lambda (varname) + (eval-wish + (string-append + "set ::scmVar(" + (form->string varname) + ")")))) + +(define set-var! + (lambda (varname value) + (eval-wish + (string-append + "set ::scmVar(" + (form->string varname) + ") {" + (form->string value) + "}")))) + +(define start + (lambda () + (start-wish) + (wish tk-init-string) + (set! tk-ids+widgets '()) + (set! tk-widgets '()) + (set! in-callback #f) + (set! tk (make-widget-by-id 'toplevel "." 'class: 'Wish)) + (set! commands-invoked-by-tk '()) + (set! inverse-commands-invoked-by-tk '()) + (tk/wm 'protocol tk 'WM_DELETE_WINDOW end-tk))) + +(define end-tk + (lambda () + (set! tk-is-running #f) + (wish "after 200 exit"))) + +(define ispatch-event + (lambda () + (let ((tk-statement (read-wish))) + (if (and (list? tk-statement) + (eq? (car tk-statement) 'call)) + (apply call-by-key (cdr tk-statement)))))) + +(define loop + (lambda () + (cond ((not tk-is-running) + (if wish-output + (tk/wm 'protocol tk 'WM_DELETE_WINDOW '()))) + (else (dispatch-event) + (loop))))) + +(define event-loop + (lambda () + (set! tk-is-running #t) + (loop))) + +(define map-ttk-widgets + (lambda (x) + (cond ((eq? x 'all) + (set! ttk-widget-map '("button" "checkbutton" "radiobutton" + "menubutton" "label" "entry" "frame" + "labelframe" "scrollbar" "notebook" + "progressbar" "combobox" "separator" + "scale" "sizegrip" "treeview"))) + ((eq? x 'none) + (set! ttk-widget-map '())) + ((pair? x) (set! ttk-widget-map + (map form->string x))) + (else (report-error + (string-append + "Argument to TTK-MAP-WIDGETS must be " + "ALL, NONE or a list of widget types.")))))) + +(define string-split + (lambda (c s) + (letrec + ((split (lambda (i k tmp res) + (cond ((= i k) + (if (null? tmp) res (cons tmp res))) + ((char=? (string-ref s i) c) + (split (+ i 1) k "" (cons tmp res))) + (else (split (+ i 1) k + (string-append tmp + (string (string-ref s i))) + res)))))) + (reverse (split 0 (string-length s) "" '()))))) + +(define ttk-available-themes + (lambda () + (string-split #\space (eval-wish "ttk::style theme names")))) + +(define do-wait-for-window + (lambda (w) + (dispatch-event) + (cond ((equal? (tk/winfo 'exists w) "0") '()) + (else (do-wait-for-window w))))) + +(define wait-for-window + (lambda (w) + (let ((outer-allow callback-mutex)) + (set! callback-mutex #t) + (do-wait-for-window w) + (set! callback-mutex outer-allow)))) + +(define wait-until-visible + (lambda (w) + (tk/wait 'visibility w))) + +(define lock! + (lambda () + (set! callback-mutex + (cons callback-mutex #t)))) + +(define unlock! + (lambda () + (if (pair? callback-mutex) + (set! callback-mutex + (cdr callback-mutex))))) + +(define with-lock + (lambda (thunk) + (lock!) + (thunk) + (unlock!))) + +;;; End weird letrec definitions. + +(set! tk-eval eval-wish) +(set! tk-id->widget id->widget) +(set! tk-var var) +(set! tk-get-var get-var) +(set! tk-set-var! set-var!) +(set! tk-start start) +(set! tk-end end-tk) +(set! tk-dispatch-event dispatch-event) +(set! tk-event-loop event-loop) +(set! tk-wait-for-window wait-for-window) +(set! tk-wait-until-visible wait-until-visible) +(set! tk-with-lock with-lock) +(set! tk/after (make-wish-func 'after)) +(set! tk/bell (make-wish-func 'bell)) +(set! tk/update (make-wish-func 'update)) +(set! tk/clipboard (make-wish-func 'clipboard)) +(set! tk/bgerror (make-wish-func 'bgerror)) +(set! tk/bind (make-wish-func 'bind)) +(set! tk/bindtags (make-wish-func 'bindtags)) +(set! tk/destroy (make-wish-func 'destroy)) +(set! tk/event (make-wish-func 'event)) +(set! tk/focus (make-wish-func 'focus)) +(set! tk/grab (make-wish-func 'grab)) +(set! tk/grid (make-wish-func 'grid)) +(set! tk/image (make-wish-func 'image)) +(set! tk/lower (make-wish-func 'lower)) +(set! tk/option (make-wish-func 'option)) +(set! tk/pack (make-wish-func 'pack)) +(set! tk/place (make-wish-func 'place)) +(set! tk/raise (make-wish-func 'raise)) +(set! tk/selection (make-wish-func 'selection)) +(set! tk/winfo (make-wish-func 'winfo)) +(set! tk/wm (make-wish-func 'wm)) +(set! tk/choose-color (make-wish-func "tk_chooseColor")) +(set! tk/choose-directory (make-wish-func "tk_chooseDirectory")) +(set! tk/dialog (make-wish-func "tk_dialog")) +(set! tk/get-open-file (make-wish-func "tk_getOpenFile")) +(set! tk/get-save-file (make-wish-func "tk_getSaveFile")) +(set! tk/message-box (make-wish-func "tk_messageBox")) +(set! tk/focus-follows-mouse (make-wish-func "tk_focusFollowsMouse")) +(set! tk/focus-next (make-wish-func "tk_focusNext")) +(set! tk/focus-prev (make-wish-func "tk_focusPrev")) +(set! tk/popup (make-wish-func "tk_popup")) +(set! tk/wait (lambda args (make-wish-func 'tkwait))) +(set! tk/appname (make-wish-func "tk appname")) +(set! tk/caret (make-wish-func "tk caret")) +(set! tk/scaling (make-wish-func "tk scaling")) +(set! tk/useinputmethods (make-wish-func "tk useinputmethods")) +(set! tk/windowingsystem (make-wish-func "tk windowingsystem")) +(set! ttk/available-themes ttk-available-themes) +(set! ttk/set-theme (make-wish-func "ttk::style theme use")) +(set! ttk/style (make-wish-func "ttk::style")) +(set! ttk-map-widgets map-ttk-widgets)