source: project/release/3/PS-tk/PS-tk.scm @ 11920

Last change on this file since 11920 was 11920, checked in by Kon Lovett, 13 years ago

Update to latest (and last I understand) version.

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