From: Matt Birkholz Date: Fri, 16 Sep 2011 18:27:01 +0000 (-0700) Subject: Fiddled comments, tracing. "typein buffer" replaced "minibuffer". X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~101 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cf0a132d71d22a2acd6f87ca68f3ff7316549a7e;p=mit-scheme.git Fiddled comments, tracing. "typein buffer" replaced "minibuffer". --- diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index d3b8caba4..564314641 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -225,16 +225,12 @@ USA. (let ((window (screen-cursor-window screen))) (and window (window-text-widget* window)))) -(define-integrable (minibuffer-widget? widget) - (and (text-widget? widget) - (not (text-widget-modeline widget)))) - (define-integrable (car* obj) (and (pair? obj) (car obj))) (define-integrable (cdr* obj) (and (pair? obj) (cdr obj))) (define-method set-screen-size! ((screen ) x-size y-size) - (%trace ";((set-screen-size! ) "screen" "x-size"x"y-size")\n") + (%trace "; (set-screen-size! ) "screen" "x-size"x"y-size"\n") (without-interrupts (lambda () (set-screen-x-size! screen x-size) @@ -348,10 +344,7 @@ USA. (let ((widget (window-text-widget* frame))) (if (not widget) (error "No widget:" frame)) - (%trace "; "what"...\n") - (let ((value (operation widget))) - (%trace "; ..."what" => "value"\n") - value))) + (operation widget))) (define-method screen/window-scroll-y-relative! ((screen ) frame delta) @@ -749,7 +742,7 @@ USA. (re-pack-inferiors! (reverse (window-inferiors root)) top-box '() "--") (%trace "; -show-init "toplevel"\n") - (gtk-widget-grab-focus (minibuffer-widget screen)) + (gtk-widget-grab-focus (typein-widget screen)) (gtk-widget-show-all toplevel) (%trace "; update-widgets init done\n")) (begin @@ -760,55 +753,7 @@ USA. (re-pack-inferiors! (reverse (window-inferiors root)) top-box (gtk-container-children top-box) "--") - ;; This causes the realize callback to be invoked, - ;; BEFORE the size_allocation callback! - ;; - ;; Wait for the resize idle task to do its thing? Nope. - ;; The resizing will not include widgets that have not - ;; been shown! It seems I must show (realize) new - ;; widgets WITHOUT an allocation. - - ;; Resizing is normally top-down -- started by GtkWindow - ;; when the window manager (luser) frobs it. Bottom-up - ;; resizing should happen when containers remove or add - ;; children, calling gtk_widget_queue_resize if child - ;; and parent are visible. Unfortunately, - ;; gtk_box_pack_start/end do NOT call _queue_resize. - ;; gtk_box_remove DOES (as well as _set_child_packing, - ;; _reorder_child, _set_spacing, _set_homogenous, and - ;; _set_property). MUST CALL gtk_container_queue_resize - ;; on box if new widgets are packed??? BUT can this - ;; even happen? Why were there no resizes done before??? - - ;; gtk_widget_queue_resize travels up the parent links - ;; by default??? To the top-level??? Is that when - ;; gtk_window_show has a shot? - - ;; GtkWindow's gtk_container_check_resize method just - ;; works the gtk_window_move_resize magic. - - ;; This, alone, does nothing. Resizing is done before - ;; new widgets are shown. - ;; - ;; (%trace "; -show-all "toplevel"\n") - ;; (gtk-widget-show-all toplevel) - - ;; This also does nothing; at least it does not get any - ;; re-allocations done. It skips the unshown? - ;; - ;; (%trace "; -check-resize "toplevel"\n") - ;; (gtk-container-check-resize toplevel) - ;; (%trace "; -show-all "toplevel"\n") - ;; (gtk-widget-show-all toplevel) - - ;; Internal shows also kick off Realizes after(?) the - ;; topmost new widget is packed. Showing the new then - ;; packing it, or packing the new then showing it, or - ;; packing then show-alling at the end. They all wind - ;; up in Realize before getting an allocation. - (%trace "; -show-all "toplevel"\n") - ;;(gtk-widget-grab-focus (minibuffer-widget screen)) (gtk-widget-show-all toplevel) (%trace "; update-widgets done\n"))))) @@ -894,7 +839,7 @@ USA. (set-fix-layout-size! widget new-width new-height)))))))) (define (pack-new! box window prefix) - (%trace "; "prefix"pack-new! "box" "window"\n") + (%trace "; "prefix"pack-new! "window" in "box"\n") (cond ((combination? window) (let ((new (if (combination-vertical? window) @@ -902,8 +847,6 @@ USA. (new-prefix (string-append prefix "--"))) (for-each (lambda (i) (pack-new! new (inferior-window i) new-prefix)) (window-inferiors window)) - ;;(%trace "; "prefix"pack-new! showing "box" BEFORE packing\n") - ;;(gtk-widget-show new) (%trace "; "prefix"pack-new! packing "new" in "box"\n") (gtk-box-pack-end box new #t #t 0))) ((buffer-frame? window) @@ -932,16 +875,12 @@ USA. (%widget-x-size window screen) (%widget-y-size window screen)) (gtk-box-pack-end vbox scroller #f #f 0) - ;;(%trace "; "prefix"pack-new! showing "vbox"\n") - ;;(gtk-widget-show-all vbox) (%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! showing "vbox"\n") - ;;(gtk-widget-show-all vbox) (%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") @@ -949,14 +888,15 @@ USA. )) (else (error "Unexpected Edwin window:" window)))) - (define-integrable (minibuffer-widget screen) - (any-child (lambda (widget) - (and (text-widget? widget) - (eq? #f (text-widget-modeline widget)))) - (gtk-screen-toplevel screen))) - (main))) +(define-integrable (typein-widget screen) + (let* ((top-box (car (gtk-container-reverse-children + (gtk-screen-toplevel screen)))) + ;; Typein widget is always added first -- last in the reverse list. + (typein-frame (last (gtk-container-reverse-children top-box)))) + (any-child text-widget? typein-frame))) + (define-integrable (%text-x-size window) (%window-x-size (frame-text-inferior window))) @@ -1031,14 +971,14 @@ USA. (define-guarantee text-widget "a ") (define-method initialize-instance ((widget ) x-size y-size) - (%trace ";((initialize-instance ) "widget - " "x-size" "y-size")...\n") +;;; (%trace ";(initialize-instance ) "widget +;;; " "x-size" "y-size"\n") (let ((screen (edwin-widget-screen widget))) (call-next-method widget (x-size->width screen x-size) (y-size->height screen y-size))) (let ((drawing (make-fix-drawing))) - (%trace "; drawing: "drawing"\n") +;;; (%trace "; drawing: "drawing"\n") (let ((ink (make-simple-text-ink))) (set-simple-text-ink-text! ink widget "Initial override message.") (fix-drawing-add-ink! drawing ink) @@ -1067,7 +1007,7 @@ USA. (car (fix-drawing-display-list (text-widget-override-drawing widget)))))) (define-method fix-layout-realize-callback ((widget )) - (%trace ";((fix-layout-realize-callback ) "widget")\n") + (%trace ";(fix-layout-realize-callback ) "widget"\n") (let ((geometry (fix-layout-geometry widget))) (if (or (not (fix-rect-width geometry)) (not (fix-rect-height geometry))) @@ -1089,7 +1029,7 @@ USA. (set-gtk-widget-bg-color! widget (gtk-widget-base-color widget))) (define-method fix-layout-new-geometry-callback ((widget )) - (%trace ";((fix-layout-new-geometry-callback ) "widget")\n") + (%trace ";(fix-layout-new-geometry-callback ) "widget"\n") (call-next-method widget) (thread-queue/queue-no-hang! event-queue @@ -1225,11 +1165,11 @@ USA. ()) (define-method initialize-instance ((widget )) - (%trace ";((initialize-instance ) "widget")...\n") +;;; (%trace ";(initialize-instance ) "widget"\n") (let ((screen (edwin-widget-screen widget))) (call-next-method widget -1 (y-size->height screen 1))) (let ((drawing (make-fix-drawing))) - (%trace ";\t drawing: "drawing"\n") +;;; (%trace "; drawing: "drawing"\n") (let ((ink (make-simple-text-ink))) (set-simple-text-ink-text! ink widget "--------Initial mode line.--------------------------------") @@ -1247,7 +1187,7 @@ USA. widget) (define-method fix-layout-realize-callback ((widget )) - (%trace ";((fix-layout-realize-callback ) "widget")\n") + (%trace ";(fix-layout-realize-callback ) "widget"\n") (let ((geometry (fix-layout-geometry widget))) (if (or (not (fix-rect-width geometry)) (not (fix-rect-height geometry))) @@ -1279,7 +1219,7 @@ USA. ) (define-method initialize-instance ((widget )) - (%trace ";((initialize-instance ) "widget")...\n") +;;; (%trace ";(initialize-instance ) "widget"\n") (call-next-method widget #f 0)) ;; Assume there is one text-widget in a buffer-frame-widget. @@ -1443,12 +1383,12 @@ USA. (old-drawing (text-widget-buffer-drawing widget)) (old-buffer (and old-drawing (buffer-drawing-buffer old-drawing)))) - (%trace ";\tnew/old buffer: "new-buffer - "/"old-buffer" ("old-drawing")\n") (if (and old-buffer (eq? new-buffer old-buffer) old-drawing (drawing-match? old-drawing)) (%trace ";\tno change\n") (let ((new-drawing (find/create-drawing widget))) + (%trace ";\tnew/old buffer: "new-buffer + "/"old-buffer" ("old-drawing")\n") (set-text-widget-buffer-drawing! widget new-drawing) (re-cursor widget new-drawing) (if (not (eq? (fix-layout-drawing widget) @@ -1513,8 +1453,7 @@ USA. (eq? (%window-char-image-strings bufwin) (buffer-drawing-char-image-strings drawing))))) - (main)) - (%trace "; update-widget-buffer done\n")) + (main))) (define (update-window widget) (%trace "; update-window "widget"\n") @@ -1565,6 +1504,8 @@ USA. (define modeline-image "") (define (update-modeline widget) + ;; Must be last in the update process. Some of its state depends on + ;; the final scroll position! (%trace "; update-modeline "widget"\n") (let* ((window (text-widget-buffer-frame widget)) ;; Add a few columns so the text runs past scrollbars and @@ -2229,13 +2170,14 @@ USA. (mark-permanent-copy window-point)) (redraw-cursor widget window-point)))) ;; Get cursor appearance right per current mode. An active - ;; minibuffer looks selected, else invisible. An active buffer + ;; typein window looks selected, else invisible. An active buffer ;; looks selected, else visible. (let ((selected (screen-cursor-window (window-screen window)))) (cond ((eq? window selected) (set-box-ink-shadow! cursor 'etched-in) (visible! cursor #t)) - ((minibuffer-widget? widget) + ((and (text-widget? widget) + (not (text-widget-modeline widget))) (set-box-ink-shadow! cursor 'etched-out) (visible! cursor #f)) (else ;; text widget