source: project/PS-tk/PS-tk.scm @ 5038

Last change on this file since 5038 was 5038, checked in by Kon Lovett, 14 years ago

Made chicken cond. Rmvd older src.

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