\f
(define (update-widgets screen)
(%trace "; update-widgets "screen"\n")
- (let* ((root (screen-root-window screen)) ;editor-frame
- (toplevel (gtk-screen-toplevel screen))
- (top-children (gtk-container-reverse-children toplevel)))
- (define-integrable (main)
+ (define-integrable (main)
+ (let* ((root (screen-root-window screen)) ;editor-frame
+ (toplevel (gtk-screen-toplevel screen))
+ (top-children (gtk-container-reverse-children toplevel)))
(update-name screen)
(if (null? top-children)
(let ((top-box (gtk-vbox-new #f 0)))
(gtk-container-add toplevel top-box)
(%trace "; -init "root" in "top-box"\n")
- (re-pack-windows! (%reversed-children root) top-box '() "--")
+ (re-pack-windows! (%reversed-children root)
+ '() top-box #f "--")
(%trace "; -show-init "toplevel"\n")
(gtk-widget-grab-focus (typein-widget screen))
(for-each-text-widget screen update-widget-buffer)
(gtk-widget-show-all toplevel)
(%trace "; update-widgets init done\n"))
- (begin
- (if (not (= 1 (length top-children)))
- (error "Not a GtkBin:" toplevel))
- (let ((top-box (car top-children)))
- (%trace "; -pack "root" into "top-box"\n")
- (re-pack-windows! (%reversed-children root)
- top-box (gtk-container-children top-box)
- "--")
- (%trace "; -show-all "toplevel"\n")
- (for-each-text-widget screen update-widget-buffer)
- (gtk-widget-show-all toplevel)
- (%trace "; update-widgets done\n")))))
-
- (define (re-pack-windows! windows box widgets prefix)
- (cond ((and (not (pair? windows))
- (not (pair? widgets)))
- (%trace "; "prefix"done\n"))
- ((not (pair? windows)) ;extra children
- (for-each (lambda (child)
- (%trace "; "prefix"destroying extra "child"\n")
- (gtk-object-destroy child))
- widgets)
- (%trace "; "prefix"done, tossed extra children\n"))
- ((not (pair? widgets))
- ;; and (pair? windows) -- insufficient children
- (pack-new! box (car windows) prefix)
- (re-pack-windows! (cdr windows) box '() prefix))
- (else ;; (and (pair? widgets) (pair? windows))
- (let ((widget (car widgets))
- (window (car windows)))
- (cond
-
- ;; Exact combo. match.
- ((and (combination? window)
- (not (buffer-frame-widget? widget))
- (if (combination-vertical? window)
- (gtk-vbox? widget)
- (gtk-hbox? widget)))
- (%trace "; "prefix"matched "window" to "widget"\n")
- (re-pack-windows! (%reversed-children window)
- widget
- (gtk-container-children widget)
- (string-append prefix "--"))
- (re-pack-windows! (cdr windows) box (cdr widgets) prefix))
-
- ;; Exact leaf match.
- ((and (buffer-frame? window)
- (buffer-frame-widget? widget)
- (let ((text (buffer-frame-widget-text* widget)))
- (and (eq? window (text-widget-buffer-frame text))
- text)))
- => (lambda (text)
- (%trace "; "prefix"matched "window" to "
- widget" (containing "text")\n")
- (re-size! text window)
- (re-pack-windows! (cdr windows)
- box (cdr widgets) prefix)))
-
- (else
- ;; Children were added/removed. Must remove the rest
- ;; before adding any, to get the ordering right. For
- ;; now, just remove one, in case one child was removed
- ;; and we will match the next...
- (%trace "; "prefix"destroying "widget
- ", which mismatched "window"\n")
- (gtk-object-destroy widget)
- (re-pack-windows! windows box (cdr widgets) prefix)))))))
+ (let ((top-box (car top-children)))
+ (%trace "; -pack "root" into "top-box"\n")
+ (re-pack-windows! (%reversed-children root)
+ (gtk-container-children top-box) top-box #f "--")
+ (for-each-text-widget screen update-widget-buffer)
+ (%trace "; -show-all "toplevel"\n")
+ (gtk-widget-show-all toplevel)
+ (%trace "; update-widgets done\n")))))
+
+ (define (re-pack-windows! windows widgets box resizer prefix)
+ (cond
+
+ ((and (not (pair? windows))
+ (not (pair? widgets)))
+ (%trace "; "prefix"done\n"))
+
+ ((not (pair? windows)) ;extra children
+ (for-each (lambda (child)
+ (%trace "; "prefix"destroying extra "child"\n")
+ (gtk-object-destroy child))
+ widgets)
+ (%trace "; "prefix"done, tossed extra children\n"))
+
+ ((not (pair? widgets))
+ ;; and (pair? windows) -- insufficient children
+ (pack-new! windows box resizer prefix))
+
+ (else ;; (and (pair? widgets) (pair? windows))
+ (let ((widget (car widgets))
+ (window (car windows)))
+ (cond
+
+ ;; Exact combo. match.
+ ((and (combination? window)
+ (not (buffer-frame-widget? widget))
+ (if (combination-vertical? window)
+ (gtk-vbox? widget)
+ (gtk-hbox? widget)))
+ (%trace "; "prefix"matched "window" to "widget"\n")
+ (re-pack-windows! (%reversed-children window)
+ (gtk-container-children widget)
+ widget #f (string-append prefix "--"))
+ (re-pack-resizer! windows widgets box resizer prefix))
+
+ ;; Exact leaf match.
+ ((and (buffer-frame? window)
+ (buffer-frame-widget? widget)
+ (let ((text (buffer-frame-widget-text* widget)))
+ (and text
+ (eq? window (text-widget-buffer-frame text))
+ text)))
+ => (lambda (text)
+ (%trace "; "prefix"matched "window" to "
+ widget" (containing "text")\n")
+ (re-size! text window)
+ (re-pack-resizer! windows widgets box resizer prefix)))
+
+ (else
+ ;; Children were added/removed. Must remove the rest
+ ;; before adding any, to get the ordering right. For
+ ;; now, just remove one, in case one child was removed
+ ;; and we will match the next...
+ (%trace "; "prefix"destroying "widget
+ ", which mismatched "window"\n")
+ (gtk-object-destroy widget)
+ (re-pack-windows! windows (cdr widgets) box resizer prefix)))))))
+
+ (define (re-pack-resizer! windows widgets box resizer prefix)
+ ;; (car WINDOWS) matched (car WIDGETS) and was re-packed. Now
+ ;; link the latter to the previous RESIZER, find or add the next
+ ;; resizer (if needed), then tail-call re-pack-windows! on the
+ ;; rest.
+ (if (and resizer
+ (not (eq? (car widgets) (fix-resizer-resizee resizer))))
+ (set-fix-resizer-resizee! resizer (car widgets)))
+
+ (if (and (gtk-hbox? box) (pair? (cdr windows)))
+ ;; Need resizer.
+ (let ((resizer (and (pair? (cdr widgets))
+ (fix-resizer? (cadr widgets))
+ (cadr widgets))))
+ (if resizer
+ (re-pack-windows! (cdr windows) (cddr widgets) box resizer prefix)
+ (let ((new (make-fix-resizer (gtk-screen-char-width screen) -1)))
+ (gtk-box-pack-end box new #f #f 0)
+ (for-each
+ (lambda (w)
+ (outf-error "; "prefix"destroying unexpected "w"\n")
+ (gtk-object-destroy w))
+ (cdr widgets))
+ (re-pack-windows! (cdr windows) '() box new prefix))))
+ ;; Need NO resizer.
+ (re-pack-windows! (cdr windows) (cdr widgets) box #f prefix)))
(define (re-size! widget window)
(let ((area (fix-widget-geometry widget))
"("new-width"x"new-height")\n")
(set-fix-widget-size! widget new-width new-height))))))))
- (define (pack-new! box window prefix)
- (%trace "; "prefix"pack-new! "window" in "box"\n")
- (cond
- ((combination? window)
- (let ((new (if (combination-vertical? window)
- (gtk-vbox-new #f 0) (gtk-hbox-new #f 0)))
- (new-prefix (string-append prefix "--")))
- (for-each (lambda (window) (pack-new! new window new-prefix))
- (%reversed-children window))
- (%trace "; "prefix"pack-new! packing "new" in "box"\n")
- (gtk-box-pack-end box new #t #t 0)))
- ((buffer-frame? window)
- (let ((vbox (make-buffer-frame-widget))
- (text (make-text-widget screen
- (%text-x-size window)
- (%text-y-size window)))
- (scroller (gtk-scrolled-window-new))
- (modeline (if (not (frame-modeline-inferior window))
- #f
- (make-modeline-widget screen)))
- (y-step (fix:+ (gtk-screen-line-height screen)
- (gtk-screen-line-spacing screen)))
- (x-step (gtk-screen-char-width screen)))
- (set-text-widget-buffer-frame! text window)
- (set-text-widget-modeline! text modeline)
- (set-fix-layout-scroll-step! text x-step y-step)
- (gtk-scrolled-window-set-policy scroller 'auto 'always)
- (gtk-scrolled-window-set-placement scroller 'bottom-left)
- (gtk-container-add scroller text)
- (if (not modeline)
- ;; No modeline: the window/text-widget should NOT expand.
- (begin
- ;; This is also necessary! Why???
- (gtk-widget-set-size-request scroller
- (%widget-x-size window screen)
- (%widget-y-size window screen))
- (gtk-box-pack-end vbox scroller #f #f 0)
- (%trace "; "prefix"pack-new! packing "vbox" into "box"\n")
- (gtk-box-pack-end box vbox #f #f 0))
- ;; With modeline: vbox and scroller SHOULD expand.
- (begin
- (gtk-box-pack-end vbox modeline #f #f 0)
- (gtk-box-pack-end vbox scroller #t #t 0)
- (%trace "; "prefix"pack-new! packing "vbox" into "box"\n")
- (gtk-box-pack-end box vbox #t #t 0)))
- ;;(%trace "; "prefix"pack-new! showing "vbox"\n")
- ;;(gtk-widget-show-all vbox)
- ))
- (else (error "Unexpected Edwin window:" window))))
-
- (main)))
+ (define (pack-new! windows box resizer prefix)
+ (let ((window (car windows)))
+ (%trace "; "prefix"pack-new! "window" in "box"\n")
+ (cond
+ ((combination? window)
+ (let ((new (if (combination-vertical? window)
+ (gtk-vbox-new #f 0)
+ (gtk-hbox-new #f 0)))
+ (new-prefix (string-append prefix "--")))
+ (pack-new! (%reversed-children (car windows)) new #f new-prefix)
+ (gtk-box-pack-end box new #t #t 0)
+ (%trace "; "prefix"packed "new" in "box"\n")
+ (if resizer (set-fix-resizer-resizee! resizer new))
+ (if (and (gtk-hbox? box) (pair? (cdr windows)))
+ ;; Need resizer.
+ (let ((new-resizer
+ (make-fix-resizer (gtk-screen-char-width screen) -1)))
+ (gtk-box-pack-end box new-resizer #f #f 0)
+ (pack-new! (cdr windows) box new-resizer prefix))
+ ;; Need NO resizer.
+ (if (pair? (cdr windows))
+ (pack-new! (cdr windows) box #f prefix)))))
+
+ ((buffer-frame? window)
+ (let ((vbox (make-buffer-frame-widget))
+ (text (make-text-widget screen
+ (%text-x-size window)
+ (%text-y-size window)))
+ (scroller (gtk-scrolled-window-new))
+ (modeline (if (not (frame-modeline-inferior window))
+ #f
+ (make-modeline-widget screen)))
+ (y-step (fix:+ (gtk-screen-line-height screen)
+ (gtk-screen-line-spacing screen)))
+ (x-step (gtk-screen-char-width screen)))
+ (set-text-widget-buffer-frame! text window)
+ (set-text-widget-modeline! text modeline)
+ (set-fix-layout-scroll-step! text x-step y-step)
+ (gtk-scrolled-window-set-policy scroller 'auto 'always)
+ (gtk-scrolled-window-set-placement scroller 'bottom-left)
+ (gtk-container-add scroller text)
+ (if (not modeline)
+ ;; No modeline: the window/text-widget should NOT expand.
+ (begin
+ ;; This is also necessary! Why???
+ (gtk-widget-set-size-request scroller
+ (%widget-x-size window screen)
+ (%widget-y-size window screen))
+ (gtk-box-pack-end vbox scroller #f #f 0)
+ (gtk-box-pack-end box vbox #f #f 0)
+ (%trace "; "prefix"packed "vbox" into "box"\n"))
+ ;; With modeline: vbox and scroller SHOULD expand.
+ (begin
+ (gtk-box-pack-end vbox modeline #f #f 0)
+ (gtk-box-pack-end vbox scroller #t #t 0)
+ (gtk-box-pack-end box vbox #t #t 0)
+ (%trace "; "prefix"packed "vbox" into "box"\n")))
+ (if resizer (set-fix-resizer-resizee! resizer vbox))
+ (if (and (gtk-hbox? box) (pair? (cdr windows)))
+ ;; Need resizer.
+ (let ((new-resizer
+ (make-fix-resizer (gtk-screen-char-width screen) -1)))
+ (gtk-box-pack-end box new-resizer #f #f 0)
+ (pack-new! (cdr windows) box new-resizer prefix))
+ ;; Need NO resizer.
+ (if (pair? (cdr windows))
+ (pack-new! (cdr windows) box #f prefix)))))
+ (else (error "Unexpected Edwin window:" window)))))
+
+ (main))
(define-integrable (typein-widget screen)
(let* ((top-box (car (gtk-container-reverse-children
projects / mit-scheme.git / commitdiff