pstk.scm (33661B)
1 ;;; PS/Tk -- A Portable Scheme Interface to the Tk GUI Toolkit 2 ;;; Copyright (C) 2021-2022 Daniil Archangelsky aka Kiky Tokamuro 3 ;;; Copyright (C) 2008 Kenneth A Dickey 4 ;;; Copyright (C) 2006-2008 Nils M Holm 5 ;;; Copyright (C) 2004 Wolf-Dieter Busch 6 ;;; All rights reserved. 7 ;;; 8 ;;; Redistribution and use in source and binary forms, with or without 9 ;;; modification, are permitted provided that the following conditions 10 ;;; are met: 11 ;;; 1. Redistributions of source code must retain the above copyright 12 ;;; notice, this list of conditions and the following disclaimer. 13 ;;; 2. Redistributions in binary form must reproduce the above copyright 14 ;;; notice, this list of conditions and the following disclaimer in the 15 ;;; documentation and/or other materials provided with the distribution. 16 ;;; 17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 18 ;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 21 ;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 ;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 ;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 ;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 ;;; SUCH DAMAGE. 28 ;;; 29 ;;; PS/Tk is based on Chicken/Tk by Wolf-Dieter Busch (2004): 30 ;;; http://wolf-dieter-busch.de/html/Software/Tools/ChickenTk.htm 31 ;;; which is in turn based on Scheme_wish by Sven Hartrumpf (1997, 1998): 32 ;;; http://pi7.fernuni-hagen.de/hartrumpf/scheme_wish.scm 33 ;;; 34 ;;; These are the changes that I (Nils) made to turn Chicken/Tk into PS/Tk: 35 ;;; 36 ;;; - Removed all Chicken-isms except for PROCESS. 37 ;;; - All PS/Tk function names begin with TK/ or TK-: 38 ;;; EVAL-WISH --> TK-EVAL-WISH 39 ;;; GET-TK-VAR --> TK-GET-VAR 40 ;;; SET-TK-VAR! --> TK-SET-VAR! 41 ;;; START-TK --> TK-START 42 ;;; END-TK --> TK-END 43 ;;; EVENT-LOOP --> TK-EVENT-LOOP 44 ;;; - Added TK-DISPATCH-EVENT. 45 ;;; - Added TK-WAIT-FOR-WINDOW because TK/WAIT returned too early. 46 ;;; - Removed some unused functions and variables. 47 ;;; - Replaced keyword lists with property lists. 48 ;;; - Removed ScrolledText compound widget. 49 ;;; - Removed :WIDGET-NAME option. 50 ;;; - Added a PLT Scheme version of RUN-PROGRAM. 51 ;;; 52 ;;; Contributions (in order of appearance): 53 ;;; - Jens Axel Soegaard: PLT Scheme/Windows RUN-PROGRAM. 54 ;;; - Taylor R Campbell: Scheme48 RUN-PROGRAM, portable GENSYM, and some R5RS 55 ;;; portability fixes. 56 ;;; - Jeffrey T. Read: Gambit hacks (RUN-PROGRAM, keyword hack). 57 ;;; - Marc Feeley: Various versions of RUN-PROGRAM (Bigloo, Gauche, Guile, 58 ;;; Kawa, Scsh, Stklos), SRFI-88 keyword auto-detection, some bug fixes. 59 ;;; - David St-Hilaire: suggested catching unspecific value in form->string. 60 ;;; - Ken Dickey: added Ikarus Scheme 61 ;;; - Ken Dickey: added Larceny Scheme 62 ;;; Thank you! 63 ;;; 64 ;;; Change Log: 65 ;;; 2022-03-07 Added tk-throw for turn Tk error to Scheme errors 66 ;;; Added application termination in case of error in pipe to scheme process 67 ;;; 2022-03-05 Rewrited on Guile module 68 ;;; Changed "_IONBF" to 'none 69 ;;; 2021-12-01 Deleted all non Guile sections. 70 ;;; Changed "set-batch-mode?!" to "ensure-batch-mode!". 71 ;;; Deleted the "bottom" function call. 72 ;;; 2008-06-22 Added Larceny Scheme support. 73 ;;; 2008-02-29 Added R6RS (Ikarus Scheme) support, added TTK/STYLE. 74 ;;; 2007-06-27 Renamed source file to pstk.scm. 75 ;;; 2007-06-27 Re-factored some large procedures, applied some cosmetics. 76 ;;; 2007-06-26 FORM->STRING catches unspecific values now, so event handlers 77 ;;; no longer have to return specific values. 78 ;;; 2007-06-26 Re-imported the following ports from the processio/v1 snowball: 79 ;;; Bigloo, Gauche, Guile, Kawa, Scsh, Stklos. 80 ;;; 2007-06-26 Added auto-detection of SRFI-88 keywords. 81 ;;; 2007-03-03 Removed callback mutex, because it blocked some redraw 82 ;;; operations. Use TK-WITH-LOCK to protect critical sections. 83 ;;; 2007-02-03 Added Tile support: TTK-MAP-WIDGETS, TTK/AVAILABLE-THEMES, 84 ;;; TTK/SET-THEME. 85 ;;; 2007-01-20 Added (Petite) Chez Scheme port. 86 ;;; 2007-01-06 Fix: TK-WAIT-FOR-WINDOW requires nested callbacks. 87 ;;; 2007-01-05 Added code to patch through fatal TCL messages. 88 ;;; 2007-01-05 Protected call-backs by a mutex, so accidental double 89 ;;; clicks, etc cannot mess up program state. 90 ;;; 2006-12-21 Made FORM->STRING accept '(). 91 ;;; 2006-12-18 Installing WM_DELETE_WINDOW handler in TK-START now, so it does 92 ;;; not get reset in TK-EVENT-LOOP. 93 ;;; 2006-12-18 Made TK-START and TK-END return () instead of #<unspecific> 94 ;;; (which crashes FORM->STRING). 95 ;;; 2006-12-12 Fixed some wrong Tcl quotation (introduced by myself). 96 ;;; 2006-12-09 Added TK/BELL procedure. 97 ;;; 2006-12-08 Replaced ATOM->STRING by FORM->STRING. 98 ;;; 2006-12-06 Added TK-WAIT-UNTIL-VISIBLE. 99 ;;; 2006-12-03 Made more variables local to outer LETREC. 100 ;;; 2006-12-03 Added Gambit port and keywords hack. 101 ;;; 2006-12-02 Added Scheme 48 port, portable GENSYM, R5RS fixes. 102 ;;; 2006-12-02 Added PLT/Windows port. 103 104 (define-module (pstk) 105 #:pure 106 #:export (*wish-program* 107 *wish-debug-input* 108 *wish-debug-output* 109 tk 110 tk-throw 111 tk-dispatch-event 112 tk-end 113 tk-eval 114 tk-event-loop 115 tk-get-var 116 tk-id->widget 117 tk-set-var! 118 tk-start 119 tk-var 120 tk-wait-for-window 121 tk-wait-until-visible 122 tk-with-lock 123 tk/after 124 tk/appname 125 tk/bell 126 tk/bgerror 127 tk/bind 128 tk/bindtags 129 tk/caret 130 tk/choose-color 131 tk/choose-directory 132 tk/clipboard 133 tk/destroy 134 tk/dialog 135 tk/event 136 tk/focus 137 tk/focus-follows-mouse 138 tk/focus-next 139 tk/focus-prev 140 tk/get-open-file 141 tk/get-save-file 142 tk/grab 143 tk/grid 144 tk/image 145 tk/lower 146 tk/message-box 147 tk/option 148 tk/pack 149 tk/place 150 tk/popup 151 tk/raise 152 tk/scaling 153 tk/selection 154 tk/update 155 tk/useinputmethods 156 tk/wait 157 tk/windowingsystem 158 tk/winfo 159 tk/wm 160 ttk-map-widgets 161 ttk/available-themes 162 ttk/set-theme 163 ttk/style) 164 #:use-module ((guile) 165 #:select ( 166 else 167 + 168 = 169 EXIT_FAILURE 170 and 171 append 172 apply 173 assv 174 caddr 175 cadr 176 car 177 cddr 178 cdr 179 close-fdes 180 close-port 181 cond 182 case 183 cons 184 define 185 define* 186 display 187 do 188 ensure-batch-mode! 189 eof-object? 190 eq? 191 equal? 192 error 193 exit 194 false-if-exception 195 for-each 196 force-output 197 if 198 lambda 199 length 200 let 201 let* 202 list 203 list->string 204 list? 205 map 206 newline 207 not 208 null? 209 number? 210 or 211 pipe 212 primitive-fork 213 quasiquote 214 quote 215 reverse 216 set! 217 string 218 string->number 219 string-append 220 string-split 221 string-trim 222 string=? 223 string? 224 substring 225 symbol->string 226 symbol? 227 values 228 when 229 )) 230 #:use-module ((srfi srfi-11) 231 #:select 232 (let-values)) 233 #:use-module ((srfi srfi-88) #:select ()) 234 #:use-module ((ice-9 match) #:select (match)) 235 #:use-module ((ice-9 ports) #:select (call-with-input-file current-output-port current-input-port with-input-from-file read-char dup2 fileno port-for-each setvbuf)) 236 #:use-module ((ice-9 rdelim) #:select (read-line)) 237 #:use-module ((ice-9 textual-ports) #:select (get-string-all)) 238 #:use-module (raw-strings) 239 ) 240 241 (display (cond (#f #f) 242 (else 1))) 243 244 (define *wish-program* "tclsh") 245 (define *wish-debug-input* #f) 246 (define *wish-debug-output* #f) 247 248 (define *use-keywords?* 249 (or (not (symbol? 'text:)) 250 (not (symbol? ':text)) 251 (string=? "text" (symbol->string 'text:)) 252 (string=? "text" (symbol->string ':text)))) 253 254 ;; XXX: Commenting out because we are going to define them at the end. 255 ;; (define tk #f) 256 ;; (define tk-dispatch-event #f) 257 ;; (define tk-end #f) 258 ;; (define tk-eval #f) 259 ;; (define tk-event-loop #f) 260 ;; (define tk-get-var #f) 261 ;; (define tk-id->widget #f) 262 ;; (define tk-set-var! #f) 263 ;; (define tk-start #f) 264 ;; (define tk-var #f) 265 ;; (define tk-wait-for-window #f) 266 ;; (define tk-wait-until-visible #f) 267 ;; (define tk-with-lock #f) 268 ;; (define tk/after #f) 269 ;; (define tk/appname #f) 270 ;; (define tk/bell #f) 271 ;; (define tk/bgerror #f) 272 ;; (define tk/bind #f) 273 ;; (define tk/bindtags #f) 274 ;; (define tk/caret #f) 275 ;; (define tk/choose-color #f) 276 ;; (define tk/choose-directory #f) 277 ;; (define tk/clipboard #f) 278 ;; (define tk/destroy #f) 279 ;; (define tk/dialog #f) 280 ;; (define tk/event #f) 281 ;; (define tk/focus #f) 282 ;; (define tk/focus-follows-mouse #f) 283 ;; (define tk/focus-next #f) 284 ;; (define tk/focus-prev #f) 285 ;; (define tk/get-open-file #f) 286 ;; (define tk/get-save-file #f) 287 ;; (define tk/grab #f) 288 ;; (define tk/grid #f) 289 ;; (define tk/image #f) 290 ;; (define tk/lower #f) 291 ;; (define tk/message-box #f) 292 ;; (define tk/option #f) 293 ;; (define tk/pack #f) 294 ;; (define tk/place #f) 295 ;; (define tk/popup #f) 296 ;; (define tk/raise #f) 297 ;; (define tk/scaling #f) 298 ;; (define tk/selection #f) 299 ;; (define tk/update #f) 300 ;; (define tk/useinputmethods #f) 301 ;; (define tk/wait #f) 302 ;; (define tk/windowingsystem #f) 303 ;; (define tk/winfo #f) 304 ;; (define tk/wm #f) 305 ;; (define ttk-map-widgets #f) 306 ;; (define ttk/available-themes #f) 307 ;; (define ttk/set-theme #f) 308 ;; (define ttk/style #f) 309 310 (define tk-throw 311 (let ((enabled #f)) 312 (lambda (args) 313 (if (null? args) 314 enabled 315 (set! enabled (car args)))))) 316 317 (define (->string x) 318 ;; XXX: Commenting out for the simpler implementation below. 319 ;; (cond ((string? x) x) 320 ;; ((symbol? x) (symbol->string x)) 321 ;; ((char? x) (string x)) 322 ;; ((number? x) (number->string x)) 323 ;; (else 324 ;; (let ((out (open-output-string))) 325 ;; (display x out) 326 ;; (get-output-string out)))) 327 328 (with-output-to-string 329 (lambda () (display x)))) 330 331 ;;; Start weird letrec definitions: 332 333 (define nl (string #\newline)) 334 (define wish-input #f) ;; Pipe into the wish process's input. A pipe to which you write. 335 (define wish-output #f) ;; Pipe out from the wish process's output. A pipe from which you read. 336 (define tk-is-running #f) ;; Used to exit the event loop. 337 (define tk-ids+widgets '()) ;; TODO: Write comment. 338 (define tk-widgets '()) ;; TODO: Write comment. 339 (define commands-invoked-by-tk '()) ;; TODO: Write comment. 340 (define inverse-commands-invoked-by-tk '()) ;; TODO: Write comment. 341 (define in-callback #f) ;; TODO: Write comment. 342 (define callback-mutex #t) ;; TODO: Write comment. 343 (define ttk-widget-map '()) ;; TODO: Write comment. 344 (define tk-init-string (call-with-input-file "tk-init.tcl" 345 (lambda (port) 346 (get-string-all port)))) 347 348 (define (report-error x) 349 (newline) 350 (display x) 351 (newline) 352 (when (tk-throw) 353 (error 'tk (->string x)))) 354 355 (define (run-program program) 356 (define (open-i/o-process prog . args) 357 (let ((c2p (pipe)) 358 (p2c (pipe))) 359 ;; TODO: Where in Guile's modules is setvbuf defined? 360 (setvbuf (cdr c2p) 'none) 361 (setvbuf (cdr p2c) 'none) 362 (let ((pid (primitive-fork))) 363 (cond ((= pid 0) 364 (ensure-batch-mode!) 365 (let ((input-fdes (fileno (car p2c))) 366 (output-fdes (fileno (cdr c2p)))) 367 (port-for-each 368 (lambda (pt-entry) 369 (false-if-exception 370 (let ((pt-fileno (fileno pt-entry))) 371 (when (not (or (= pt-fileno input-fdes) 372 (= pt-fileno output-fdes))) 373 (close-fdes pt-fileno)))))) 374 (cond ((not (= input-fdes 0)) 375 (when (= output-fdes 0) 376 (set! output-fdes (dup->fdes 0))) 377 (dup2 input-fdes 0))) 378 (when (not (= output-fdes 1)) 379 (dup2 output-fdes 1)) 380 (apply execlp prog prog args))) 381 (else 382 (close-port (cdr c2p)) 383 (close-port (car p2c)) 384 (values (car c2p) 385 (cdr p2c))))))) 386 387 (open-i/o-process "/bin/sh" "-c" 388 (string-append "exec " program))) 389 390 (define flush-output-port force-output) 391 392 (define (flush-wish) 393 (flush-output-port wish-input)) 394 395 (define (option? x) 396 (or (and *use-keywords?* 397 (keyword? x)) 398 (and (symbol? x) 399 (let* ((s (symbol->string x)) 400 (n (string-length s))) 401 (char=? #\: (string-ref s (- n 1))))))) 402 403 (define (make-option-string x) 404 (if (and *use-keywords?* 405 (keyword? x)) 406 (string-append " -" (keyword->string x)) 407 (let ((s (symbol->string x))) 408 (string-append " -" 409 (substring s 0 (- (string-length s) 1)))))) 410 411 (define (improper-list->string possibly-improper-list) 412 ;; XXX: Commenting out and replacing with the implementation at the bottom. 413 ;; (cond ((pair? a) 414 ;; (cons (string-append (if first "" " ") 415 ;; (form->string (car a))) 416 ;; (improper-list->string (cdr a) #f))) 417 ;; ((null? a) '()) 418 ;; (else (list (string-append " . " (form->string a))))) 419 420 ;; We know we only ever get a pair as POSSIBLY-IMPROPER-LIST, so we: 421 (let loop ((result (form->string (car possibly-improper-list))) 422 ;; Take the first of argument POSSIBLY-IMPROPER-LIST 423 ;; without any space separator. 424 (a (cdr possibly-improper-list)) 425 ;; and the rest of A. 426 ) 427 (match a 428 ((first-of-a . rest-of-a) 429 ;; Now that we are sure we are in the middle of the list we can 430 ;; start adding space separators. 431 (loop (cons (string-append (form->string first-of-a) 432 " ") 433 result) 434 rest-of-a)) 435 ;; TODO: What's going on here, love? 436 (() (string-concatenate-reverse result)) 437 (improper-list-terminator 438 ;; TODO: What's going on here, love? 439 (string-concatenate-reverse 440 (cons (form->string improper-list-terminator) 441 " . " 442 result)))))) 443 444 (define (form->string x) 445 (match x 446 (#t "#t") 447 (#f "#f") 448 ((? number? x) (number->string x)) 449 ((? symbol? x) (symbol->string x)) 450 ((? string? x) x) 451 (() "()") 452 ((_ . _) 453 (string-append "(" 454 (apply string-append 455 (improper-list->string x)) 456 ")")) 457 ((eof-object? x) "#<eof>") 458 (_ "#<other>"))) 459 460 (define (string-translate s map) 461 (define (s-prepend s1 s2) 462 (cond ((null? s1) s2) 463 (else (s-prepend (cdr s1) (cons (car s1) s2))))) 464 (define (s-xlate s r) 465 (cond ((null? s) (reverse r)) 466 (else (let ((n (assv (car s) map))) 467 (cond (n (s-xlate (cdr s) 468 (s-prepend (string->list (cdr n)) r))) 469 (else (s-xlate (cdr s) 470 (cons (car s) r)))))))) 471 (list->string 472 (s-xlate (string->list s) '()))) 473 474 (define (string-trim-left str) 475 (string-trim str #\space)) 476 477 (define* (get-property key args #:optional (thunk #f)) 478 ;; XXX: Originally the function signature was (get-property key args . thunk). 479 (cond ((null? args) 480 (cond ((null? thunk) #f) 481 (else ((car thunk))))) 482 ((eq? key (car args)) 483 (cond ((pair? (cdr args)) (cadr args)) 484 (else (report-error (list 'get-property key args))))) 485 ((or (not (pair? (cdr args))) 486 (not (pair? (cddr args)))) 487 (report-error (list 'get-property key args))) 488 (else (apply get-property key (cddr args) thunk))) 489 490 ;; XXX: Not sure if it's clearer than the above. 491 (match args 492 (() 493 (match 494 ((thunk-value) 495 (thunk-value)) 496 (#f 497 #f) 498 (_ 499 (report-error (list 'get-property key args thunk))))) 500 ((and (args-key . args-rest) 501 (? eq? key args-key)) 502 (match args-rest 503 ((args-value . args-rest) 504 args-value) 505 (_ 506 (report-error (list 'get-property key args))))) 507 ((args-key args-value-0 more-value-1 . args-rest) 508 (apply get-property key (cddr args) thunk)) 509 (_ 510 (report-error (list 'get-property key args))))) 511 512 (define tcl-true? 513 (let ((false-values 514 `(0 "0" 'false "false" ,(string->symbol "0")))) 515 (lambda (obj) (not (memv obj false-values))))) 516 517 (define (widget? x) 518 ;; The AND here makes sure we return either #f or #t, nothing else. 519 ;; Either the application of MEMQ evalutates to #f thereby 520 ;; shortcircuiting the AND, or it evaluates to anything other than 521 ;; #f, and the AND evaluates #t, which is then returned. 522 (and (memq x tk-widgets) #t)) 523 524 (define (call-by-key key resultvar . args) 525 (cond ((and in-callback 526 (pair? callback-mutex)) 527 #f) 528 (else 529 (set! in-callback (cons #t in-callback)) 530 (let* ((cmd (get-property key commands-invoked-by-tk)) 531 (result (apply cmd args)) 532 (str (string-trim-left 533 (scheme-arglist->tk-argstring 534 (list result))))) 535 (set-var! resultvar str) 536 (set! in-callback (cdr in-callback)) 537 result)))) 538 539 (define gen-symbol 540 (let ((counter 0)) 541 (lambda () 542 (let ((sym (string-append "g" (number->string counter)))) 543 (set! counter (+ counter 1)) 544 (string->symbol sym))))) 545 546 (define (widget-name x) 547 (let ((name (form->string x))) 548 (cond ((member name ttk-widget-map) 549 (string-append "ttk::" name)) 550 (else name)))) 551 552 (define (make-widget-by-id type id . options) 553 (let 554 ((result 555 (lambda (command . args) 556 (case command 557 ((get-id) id) 558 ((create-widget) 559 (let* ((widget-type (widget-name (car args))) 560 (id-prefix (if (string=? id ".") "" id)) 561 (id-suffix (form->string (gen-symbol))) 562 (new-id (string-append id-prefix "." id-suffix)) 563 (options (cdr args))) 564 (eval-wish 565 (string-append 566 widget-type 567 " " 568 new-id 569 (scheme-arglist->tk-argstring options))) 570 (apply make-widget-by-id 571 (append (list widget-type new-id) 572 options)))) 573 ((configure) 574 (cond ((null? args) 575 (eval-wish 576 (string-append id " " (form->string command)))) 577 ((null? (cdr args)) 578 (eval-wish 579 (string-append 580 id 581 " " 582 (form->string command) 583 (scheme-arglist->tk-argstring args)))) 584 (else 585 (eval-wish 586 (string-append 587 id 588 " " 589 (form->string command) 590 (scheme-arglist->tk-argstring args))) 591 (do ((args args (cddr args))) 592 ((null? args) '()) 593 (let ((key (car args)) (val (cadr args))) 594 (cond ((null? options) 595 (set! options (list key val))) 596 ((not (memq key options)) 597 (set! options 598 (cons key (cons val options)))) 599 (else (set-car! (cdr (memq key options)) 600 val)))))))) 601 ((cget) 602 (let ((key (car args))) 603 (get-property 604 key 605 options 606 (lambda () 607 (eval-wish 608 (string-append 609 id 610 " cget" 611 (scheme-arglist->tk-argstring args))))))) 612 ((call exec) 613 (eval-wish 614 (string-trim-left 615 (scheme-arglist->tk-argstring args)))) 616 (else 617 (eval-wish 618 (string-append 619 id 620 " " 621 (form->string command) 622 (scheme-arglist->tk-argstring args)))))))) 623 (set! tk-widgets (cons result tk-widgets)) 624 (set! tk-ids+widgets 625 (cons (string->symbol id) 626 (cons result tk-ids+widgets))) 627 result)) 628 629 (define (scheme-arg->tk-arg x) 630 (cond ((eq? x #f) " 0") 631 ((eq? x #t) " 1") 632 ((eq? x '()) " {}") 633 ((option? x) (make-option-string x)) 634 ((widget? x) (string-append " " (x 'get-id))) 635 ((and (pair? x) (procedure? (car x))) 636 (let* ((lambda-term (car x)) 637 (rest (cdr x)) 638 (l (memq lambda-term 639 inverse-commands-invoked-by-tk)) 640 (keystr (if l (form->string (cadr l)) 641 (symbol->string (gen-symbol))))) 642 (if (not l) 643 (let ((key (string->symbol keystr))) 644 (set! inverse-commands-invoked-by-tk 645 (cons lambda-term 646 (cons key 647 inverse-commands-invoked-by-tk))) 648 (set! commands-invoked-by-tk 649 (cons key 650 (cons lambda-term 651 commands-invoked-by-tk))))) 652 (string-append " {callToScm " 653 keystr 654 (scheme-arglist->tk-argstring rest) 655 "}"))) 656 ((procedure? x) 657 (scheme-arglist->tk-argstring `((,x)))) 658 ((list? x) 659 (cond ((eq? (car x) '+) 660 (let ((result (string-trim-left 661 (scheme-arglist->tk-argstring 662 (cdr x))))) 663 (cond ((string=? result "") " +") 664 ((string=? "{" (substring result 0 1)) 665 (string-append 666 " {+ " 667 (substring result 1 668 (string-length result)))) 669 (else (string-append " +" result))))) 670 ((and (= (length x) 3) 671 (equal? (car x) (string->symbol "@")) 672 (number? (cadr x)) 673 (number? (caddr x))) 674 (string-append 675 "@" 676 (number->string (cadr x)) 677 "," 678 (number->string (caddr x)))) 679 (else 680 (string-append 681 " {" 682 (string-trim-left 683 (scheme-arglist->tk-argstring x)) 684 "}")))) 685 ((pair? x) 686 (string-append 687 " " 688 (form->string (car x)) 689 "." 690 (form->string (cdr x)))) 691 ((string? x) 692 (if (string->number x) 693 (string-append " " x) 694 (string-append 695 " \"" 696 (string-translate x 697 '((#\" . "\\\"") 698 (#\$ . "\\u0024") 699 (#\[ . "\\u005b") 700 (#\\ . "\\\\") 701 (#\] . "\\]") 702 (#\{ . "\\{") 703 (#\} . "\\}"))) 704 "\""))) 705 (else (string-append " " (form->string x))))) 706 707 (define (scheme-arglist->tk-argstring args) 708 (string-concatenate 709 (map scheme-arg->tk-arg 710 args))) 711 712 (define (make-wish-func tkname) 713 (let ((name (form->string tkname))) 714 (lambda args 715 (eval-wish 716 (string-append 717 name 718 (scheme-arglist->tk-argstring args)))))) 719 720 (define (read-wish) 721 (let ((term (read wish-output))) 722 (cond (*wish-debug-output* 723 (display "wish->scheme: ") 724 (write term) 725 (newline))) 726 term)) 727 728 (define (wish . arguments) 729 "Send ARGUMENTS to wish." 730 (for-each 731 (lambda (argument) 732 (when *wish-debug-input* 733 (display "scheme->wish: ") 734 (display argument) 735 (newline)) 736 (display argument wish-input) 737 (newline wish-input) 738 (flush-wish)) 739 arguments)) 740 741 (define (start-wish) 742 (let-values (((wish-output-pipe wish-input-pipe) 743 (run-program *wish-program*))) 744 (set! wish-input wish-input-pipe) 745 (set! wish-output wish-output-pipe))) 746 747 ;; XXX: Commenting because Guile already have a read-line. 748 ;; (define (read-line in) 749 ;; (define (collect-chars c s) 750 ;; (cond ((or (eof-object? c) (char=? c #\newline)) 751 ;; (apply string (reverse s))) 752 ;; (else (collect-chars (read-char in) (cons c s))))) 753 ;; (define first-char (read-char in)) 754 ;; (cond ((eof-object? first-char) first-char) 755 ;; (else (collect-chars first-char '())))) 756 757 (define (eval-wish cmd) 758 (wish (string-append 759 "evalCmdFromScm \"" 760 (string-translate cmd 761 '((#\" . "\\\"") 762 (#\\ . "\\\\"))) 763 "\"")) 764 (let again ((result (read-wish))) 765 (cond ((not (pair? result)) 766 (report-error (string-append 767 "An error occurred inside Tcl/Tk" nl 768 " --> " (form->string result) 769 " " (read-line wish-output)))) 770 ((eq? (car result) 'return) 771 (cadr result)) 772 ((eq? (car result) 'call) 773 (apply call-by-key (cdr result)) 774 (again (read-wish))) 775 ((eq? (car result) 'error) 776 (report-error (string-append 777 "An error occurred inside Tcl/Tk" nl 778 " " cmd nl 779 " --> " (cadr result)))) 780 (else (report-error result))))) 781 782 (define (id->widget id) 783 (get-property 784 (string->symbol (form->string id)) 785 tk-ids+widgets 786 (lambda () 787 (if (tcl-true? (tk/winfo 'exists id)) 788 (make-widget-by-id 789 (tk/winfo 'class id) 790 (form->string id)) 791 #f)))) 792 793 (define (var varname) 794 (set-var! varname "") 795 (string-append 796 "::scmVar(" 797 (form->string varname) 798 ")")) 799 800 (define (get-var varname) 801 (eval-wish 802 (string-append 803 "set ::scmVar(" 804 (form->string varname) 805 ")"))) 806 807 (define (set-var! varname value) 808 (eval-wish 809 (string-append 810 "set ::scmVar(" 811 (form->string varname) 812 ") {" 813 (form->string value) 814 "}"))) 815 816 (define (start) 817 (start-wish) 818 (wish tk-init-string) 819 (set! tk-ids+widgets '()) 820 (set! tk-widgets '()) 821 (set! in-callback #f) 822 (set! tk (make-widget-by-id 'toplevel "." 'class: 'Wish)) 823 (set! commands-invoked-by-tk '()) 824 (set! inverse-commands-invoked-by-tk '()) 825 (tk/wm 'protocol tk 'WM_DELETE_WINDOW end-tk)) 826 827 (define (end-tk) 828 (set! tk-is-running #f) 829 (wish "after 200 exit")) 830 831 (define (dispatch-event) 832 (let ((tk-statement (read-wish))) 833 (if (and (list? tk-statement) 834 (eq? (car tk-statement) 'call)) 835 (apply call-by-key (cdr tk-statement))))) 836 837 (define (loop) 838 (cond ((and (not tk-is-running) 839 wish-output) 840 (tk/wm 'protocol tk 'WM_DELETE_WINDOW '())) 841 (else (dispatch-event) 842 (loop)))) 843 844 (define (event-loop) 845 (set! tk-is-running #t) 846 (loop)) 847 848 (define (map-ttk-widgets x) 849 (cond ((eq? x 'all) 850 (set! ttk-widget-map '("button" "checkbutton" "radiobutton" 851 "menubutton" "label" "entry" "frame" 852 "labelframe" "scrollbar" "notebook" 853 "progressbar" "combobox" "separator" 854 "scale" "sizegrip" "treeview"))) 855 ((eq? x 'none) 856 (set! ttk-widget-map '())) 857 ((pair? x) (set! ttk-widget-map 858 (map form->string x))) 859 (else (report-error 860 (string-append 861 "Argument to TTK-MAP-WIDGETS must be " 862 "ALL, NONE or a list of widget types."))))) 863 864 ;;; XXX: Commented out because string-split is already part of Guile. 865 ;; (define (string-split c s) 866 ;; (define (split i k tmp res) 867 ;; (cond ((= i k) 868 ;; (if (null? tmp) res (cons tmp res))) 869 ;; ((char=? (string-ref s i) c) 870 ;; (split (+ i 1) k "" (cons tmp res))) 871 ;; (else (split (+ i 1) k 872 ;; (string-append tmp 873 ;; (string (string-ref s i))) 874 ;; res)))) 875 ;; (reverse (split 0 (string-length s) "" '()))) 876 877 (define (ttk-available-themes) 878 ;; XXX: Using the Guile string-split instead of the above commented 879 ;; out one. 880 (string-split (eval-wish "ttk::style theme names") 881 g#\space)) 882 883 (define (do-wait-for-window w) 884 (dispatch-event) 885 (cond ((equal? (tk/winfo 'exists w) "0") '()) 886 (else (do-wait-for-window w)))) 887 888 (define (wait-for-window w) 889 (let ((outer-allow callback-mutex)) 890 (set! callback-mutex #t) 891 (do-wait-for-window w) 892 (set! callback-mutex outer-allow))) 893 894 (define (wait-until-visible w) 895 (tk/wait 'visibility w)) 896 897 (define (lock!) 898 (set! callback-mutex 899 (cons callback-mutex #t))) 900 901 (define (unlock!) 902 (if (pair? callback-mutex) 903 (set! callback-mutex 904 (cdr callback-mutex)))) 905 906 (define (with-lock thunk) 907 (lock!) 908 (thunk) 909 (unlock!)) 910 911 ;;; End weird letrec definitions. 912 913 ;;; Start weird letrec body: 914 915 (define tk-eval eval-wish) 916 (define tk-id->widget id->widget) 917 (define tk-var var) 918 (define tk-get-var get-var) 919 (define tk-set-var! set-var!) 920 (define tk-start start) 921 (define tk-end end-tk) 922 (define tk-dispatch-event dispatch-event) 923 (define tk-event-loop event-loop) 924 (define tk-wait-for-window wait-for-window) 925 (define tk-wait-until-visible wait-until-visible) 926 (define tk-with-lock with-lock) 927 (define tk/after (make-wish-func 'after)) 928 (define tk/bell (make-wish-func 'bell)) 929 (define tk/update (make-wish-func 'update)) 930 (define tk/clipboard (make-wish-func 'clipboard)) 931 (define tk/bgerror (make-wish-func 'bgerror)) 932 (define tk/bind (make-wish-func 'bind)) 933 (define tk/bindtags (make-wish-func 'bindtags)) 934 (define tk/destroy (make-wish-func 'destroy)) 935 (define tk/event (make-wish-func 'event)) 936 (define tk/focus (make-wish-func 'focus)) 937 (define tk/grab (make-wish-func 'grab)) 938 (define tk/grid (make-wish-func 'grid)) 939 (define tk/image (make-wish-func 'image)) 940 (define tk/lower (make-wish-func 'lower)) 941 (define tk/option (make-wish-func 'option)) 942 (define tk/pack (make-wish-func 'pack)) 943 (define tk/place (make-wish-func 'place)) 944 (define tk/raise (make-wish-func 'raise)) 945 (define tk/selection (make-wish-func 'selection)) 946 (define tk/winfo (make-wish-func 'winfo)) 947 (define tk/wm (make-wish-func 'wm)) 948 (define tk/choose-color (make-wish-func "tk_chooseColor")) 949 (define tk/choose-directory (make-wish-func "tk_chooseDirectory")) 950 (define tk/dialog (make-wish-func "tk_dialog")) 951 (define tk/get-open-file (make-wish-func "tk_getOpenFile")) 952 (define tk/get-save-file (make-wish-func "tk_getSaveFile")) 953 (define tk/message-box (make-wish-func "tk_messageBox")) 954 (define tk/focus-follows-mouse (make-wish-func "tk_focusFollowsMouse")) 955 (define tk/focus-next (make-wish-func "tk_focusNext")) 956 (define tk/focus-prev (make-wish-func "tk_focusPrev")) 957 (define tk/popup (make-wish-func "tk_popup")) 958 (define tk/wait (lambda args (make-wish-func 'tkwait))) 959 (define tk/appname (make-wish-func "tk appname")) 960 (define tk/caret (make-wish-func "tk caret")) 961 (define tk/scaling (make-wish-func "tk scaling")) 962 (define tk/useinputmethods (make-wish-func "tk useinputmethods")) 963 (define tk/windowingsystem (make-wish-func "tk windowingsystem")) 964 (define ttk/available-themes ttk-available-themes) 965 (define ttk/set-theme (make-wish-func "ttk::style theme use")) 966 (define ttk/style (make-wish-func "ttk::style")) 967 (define ttk-map-widgets map-ttk-widgets) 968 969 ;;; End weird letrec body.