From: Matt Birkholz Date: Wed, 30 Jan 2013 15:22:32 +0000 (-0700) Subject: gtk-screen: Update to Gtk+3.6. X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~67 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4860a4f4938e0b9ba9ca1e605614cb398bfb0d9b;p=mit-scheme.git gtk-screen: Update to Gtk+3.6. Fixes for Gtk+3: Return a Schemely value from event handlers. Grab-focus AFTER typein is mapped. Set modeline font. Eliminate gtk-widget-set-size-request and fix-resizer. (Relying on natural sizes to programmatically [re]size widgets.) --- diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg index 41118da37..36890cba3 100644 --- a/src/gtk-screen/gtk-screen.pkg +++ b/src/gtk-screen/gtk-screen.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013 Matthew Birkholz This file is part of an extension to MIT/GNU Scheme. @@ -112,12 +112,12 @@ USA. gtk-widget-show gtk-widget-show-all gtk-widget-error-bell gtk-widget-queue-draw + gtk-widget-queue-resize-no-redraw gtk-widget-font set-gtk-widget-font! gtk-widget-get-pango-context gtk-widget-create-pango-layout gtk-widget-set-hexpand gtk-widget-set-vexpand - gtk-widget-set-size-request gtk-widget-bg-color set-gtk-widget-bg-color! gtk-widget-fg-color set-gtk-widget-fg-color! @@ -125,14 +125,13 @@ USA. gtk-container-children gtk-container-add gtk-container-remove gtk-container-set-border-width - gtk-scrolled-window? gtk-scrolled-window-new - gtk-scrolled-window-set-policy - gtk-scrolled-window-set-placement - gtk-grid? gtk-grid-new gtk-orientable-get-orientation gtk-orientable-set-orientation + gtk-scrolled-window-set-policy gtk-scrolled-window-set-placement + gtk-scrolled-view-new + gtk-window-new gtk-window-present gtk-window-set-title @@ -153,6 +152,9 @@ USA. pango-font-metrics-get-approximate-char-width pango-font-metrics-unref + set-scm-widget-minimum-size! + set-scm-widget-natural-size! + fix-widget? fix-widget-new-geometry-callback fix-widget-realize-callback set-fix-widget-map-handler! @@ -170,11 +172,6 @@ USA. fix-layout-scroll-step set-fix-layout-scroll-step! fix-layout-scroll-to! fix-layout-scroll-nw! - fix-resizer? - make-fix-resizer - fix-resizer-before set-fix-resizer-before! - fix-resizer-after set-fix-resizer-after! - guarantee-fix-drawing make-fix-drawing fix-drawing-widgets set-fix-drawing-size! @@ -190,5 +187,6 @@ USA. simple-text-ink? make-simple-text-ink simple-text-ink-text set-simple-text-ink-text! + set-simple-text-ink-font! set-box-ink! set-box-ink-position!)) \ No newline at end of file diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index b67b4532d..90dec5607 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013 Matthew Birkholz This file is part of an extension to MIT/GNU Scheme. @@ -130,15 +130,7 @@ USA. (declare (ignore x y)) ;; For make-editor-frame: (set-screen-x-size! screen width) - (set-screen-y-size! screen height) - (let ((toplevel (gtk-screen-toplevel screen))) - (gtk-window-set-default-size toplevel - (x-size->width screen width) - (+ (y-size->height screen (- height 2)) - ;; Modeline. - (y-size->height screen 1) - ;; Typein. - (y-size->height screen 1))))))) + (set-screen-y-size! screen height)))) (define (parse-geometry geometry receiver) (let* ((num "[0-9]+") @@ -619,21 +611,22 @@ USA. (define (map-handler widget) (%trace "; Mapped: "widget"\n") - 0 ;;Continue. - ) + (if (and (text-widget? widget) + (not (text-widget-modeline widget))) + (%trace "; grab-focus "widget"\n") + (gtk-widget-grab-focus widget)) + #f) (define (unmap-handler widget) (%trace "; Unmapped: "widget"\n") - 0 ;;Continue. - ) + #f) (define (focus-change-handler widget in?) (%trace "; Focus-"(if in? "in" "out")": "widget"\n") (let ((screen (edwin-widget-screen widget))) (set-gtk-screen-in-focus?! screen in?) (update-blinking screen)) - 0 ;;Continue. - ) + #f) (define (visibility-notify-handler widget state) (%trace "; Visibility: "state" "widget"\n") @@ -643,27 +636,28 @@ USA. ((PARTIALLY-OBSCURED) (set-screen-visibility! screen 'PARTIALLY-OBSCURED)) ((OBSCURED) (set-screen-visibility! screen 'OBSCURED)) (else (warn "unexpected visibility state:" state)))) - 1 ;;Handled. - ) + #t) (define (key-press-handler widget key char-bits) (%trace "; Key-press: "key" "char-bits" "widget"\n") (let ((queue! (lambda (x) (thread-queue/queue-no-hang! event-queue x) (%trace "; queued "x"\n") - 1 ;;Handled. - )) + #t)) (k (case key ((#\backspace) #\rubout) ((#\rubout) #\c-d) ((#\return) #\c-m) ((#\linefeed) #\c-j) ((#\tab) #\c-i) - ((Shift-L Shift-R Control-L Control-R Caps-Lock Shift-Lock - Meta-L Meta-R Alt-L Alt-R - Super-L Super-R Hyper-L Hyper-R) + ((|Shift_L| |Shift_R| |Control_L| |Control_R| + |Caps_Lock| |Shift_Lock| + |Meta_L| |Meta_R| |Alt_L| |Alt_R| + |Super_L| |Super_R| |Hyper_L| |Hyper_R|) #f) - (else key)))) + (else (if (symbol? key) + (intern (symbol-name key)) + key))))) (if (char? k) (if (char=? k #\BEL) (let* ((screen (edwin-widget-screen widget)) @@ -677,13 +671,11 @@ USA. (%trace ";interrupt! in editor "(current-thread)"\n") (interrupt!))) (%trace "; pushed ^G in "(current-thread)".\n") - 1 ;;Handled. - ) + #t) (queue! (merge-bucky-bits k char-bits))) (if k (queue! (make-special-key k char-bits)) - 1 ;;Handled. - )))) + #t)))) ;;; Initialization @@ -729,24 +721,22 @@ USA. g))) (gtk-container-add toplevel top-grid) (%trace "; -init "root" in "top-grid"\n") - (re-pack-windows! (%reversed-children root) - '() top-grid #f "--") - (%trace "; -show-init "toplevel"\n") - (gtk-widget-grab-focus (typein-widget screen)) + (re-pack-windows! (%children root) '() top-grid "--") (for-each-text-widget screen update-widget-buffer) + (%trace "; -show-init "toplevel"\n") (gtk-widget-show-all toplevel) (%trace "; update-widgets init done\n")) (let ((top-grid (car top-children))) - (%trace "; -pack "root" into "top-grid"\n") - (re-pack-windows! (%reversed-children root) + (%trace "; -re-pack "root" into "top-grid"\n") + (re-pack-windows! (%children root) (gtk-container-children top-grid) - top-grid #f "--") + top-grid "--") (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 grid resizer prefix) + (define (re-pack-windows! windows widgets grid prefix) (cond ((and (not (pair? windows)) @@ -762,7 +752,7 @@ USA. ((not (pair? widgets)) ;; and (pair? windows) -- insufficient children - (pack-new! windows grid resizer prefix)) + (pack-new! windows grid prefix)) (else ;; (and (pair? widgets) (pair? windows)) (let ((widget (car widgets)) @@ -780,10 +770,10 @@ USA. (eq? 'HORIZONTAL (gtk-orientable-get-orientation widget))))) (%trace "; "prefix"matched "window" to "widget"\n") - (re-pack-windows! (%reversed-children window) + (re-pack-windows! (%children window) (gtk-container-children widget) - widget #f (string-append prefix "--")) - (re-pack-resizer! windows widgets grid resizer prefix)) + widget (string-append prefix "--")) + (re-pack-windows! (cdr windows) (cdr widgets) grid prefix)) ;; Exact leaf match. ((and (buffer-frame? window) @@ -795,8 +785,8 @@ USA. => (lambda (text) (%trace "; "prefix"matched "window" to " widget" (containing "text")\n") - (re-size! text window) - (re-pack-resizer! windows widgets grid resizer prefix))) + (re-size! text window prefix) + (re-pack-windows! (cdr windows) (cdr widgets) grid prefix))) (else ;; Children were added/removed. Must remove the rest @@ -806,63 +796,33 @@ USA. (%trace "; "prefix"destroying "widget ", which mismatched "window"\n") (gtk-widget-destroy widget) - (re-pack-windows! windows (cdr widgets) grid resizer prefix))))))) - - (define (re-pack-resizer! windows widgets grid 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-before resizer)))) - (set-fix-resizer-before! resizer (car widgets))) - - (if (and (gtk-grid? grid) - (eq? 'HORIZONTAL (gtk-orientable-get-orientation grid)) - (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) - grid resizer prefix) - (let ((new (make-fix-resizer (gtk-screen-char-width screen) -1))) - (set-fix-resizer-after! new grid) - (gtk-container-add grid new) - (for-each - (lambda (w) - (outf-error "; "prefix"destroying unexpected "w"\n") - (gtk-widget-destroy w)) - (cdr widgets)) - (re-pack-windows! (cdr windows) '() grid new prefix)))) - ;; Need NO resizer. - (re-pack-windows! (cdr windows) (cdr widgets) grid #f prefix))) - - (define (re-size! widget window) + (re-pack-windows! windows (cdr widgets) grid prefix))))))) + + (define (re-size! widget window prefix) (let ((area (fix-widget-geometry widget)) (window-x-size (%text-x-size window)) (window-y-size (%text-y-size window))) (let ((width (fix-rect-width area)) (height (fix-rect-height area))) (if (or (not width) (not height)) - (%trace ";\t re-size!: unrealized "widget"\n") + (%trace "; "prefix"re-size!: unrealized "widget"\n") (let ((widget-x-size (width->x-size screen width)) (widget-y-size (height->y-size screen height))) (if (and (fix:= widget-x-size window-x-size) (fix:= widget-y-size window-y-size)) - (%trace ";\t re-size!: no change\n") + (%trace "; "prefix"re-size!: no change\n") (let ((new-width (x-size->width screen window-x-size)) (new-height (y-size->height screen window-y-size))) - (%trace ";\t new size request! "widget - " from "widget-x-size"x"widget-y-size" " + (%trace "; "prefix"new natural size for "widget + ": from "widget-x-size"x"widget-y-size" " "("width"x"height")" " to "window-x-size"x"window-y-size" " "("new-width"x"new-height")\n") - (gtk-widget-set-size-request widget - new-width new-height)))))))) + (set-scm-widget-natural-size! + widget new-width new-height) + (gtk-widget-queue-resize-no-redraw widget)))))))) - (define (pack-new! windows grid resizer prefix) + (define (pack-new! windows grid prefix) (let ((window (car windows))) (%trace "; "prefix"pack-new! "window" in "grid"\n") (cond @@ -876,28 +836,18 @@ USA. (begin (gtk-orientable-set-orientation new 'horizontal) (gtk-widget-set-hexpand new #t))) - (pack-new! (%reversed-children (car windows)) new #f new-prefix) + (pack-new! (%children (car windows)) new new-prefix) (gtk-container-add grid new) (%trace "; "prefix"packed "new" in "grid"\n") - (if resizer (set-fix-resizer-before! resizer new)) - (if (and (eq? 'HORIZONTAL (gtk-orientable-get-orientation grid)) - (pair? (cdr windows))) - ;; Need resizer. - (let ((new-resizer - (make-fix-resizer (gtk-screen-char-width screen) -1))) - (set-fix-resizer-after! new-resizer new) - (gtk-container-add grid new-resizer) - (pack-new! (cdr windows) grid new-resizer prefix)) - ;; Need NO resizer. - (if (pair? (cdr windows)) - (pack-new! (cdr windows) grid #f prefix))))) + (if (pair? (cdr windows)) + (pack-new! (cdr windows) grid prefix)))) ((buffer-frame? window) (let ((vgrid (make-buffer-frame-widget)) (text (make-text-widget screen (%text-x-size window) (%text-y-size window))) - (scroller (gtk-scrolled-window-new)) + (scroller (gtk-scrolled-view-new)) (modeline (if (not (frame-modeline-inferior window)) #f (make-modeline-widget screen))) @@ -912,30 +862,21 @@ USA. (if (not modeline) ;; No modeline: the window/text-widget should NOT expand. (begin + (gtk-widget-set-vexpand text #f) (gtk-container-add scroller text) (gtk-container-add vgrid scroller) (gtk-container-add grid vgrid) (%trace "; "prefix"packed "vgrid" into "grid"\n")) ;; With modeline: vgrid and scroller SHOULD expand. (begin - (gtk-widget-set-vexpand text #t) (gtk-container-add scroller text) - (gtk-container-add vgrid modeline) (gtk-container-add vgrid scroller) + (gtk-container-add vgrid modeline) (gtk-container-add grid vgrid) (%trace "; "prefix"packed "vgrid" into "grid"\n"))) - (if resizer (set-fix-resizer-before! resizer vgrid)) - (if (and (eq? 'HORIZONTAL (gtk-orientable-get-orientation grid)) - (pair? (cdr windows))) - ;; Need resizer. - (let ((new-resizer - (make-fix-resizer (gtk-screen-char-width screen) -1))) - (set-fix-resizer-after! new-resizer vgrid) - (gtk-container-add grid new-resizer) - (pack-new! (cdr windows) grid new-resizer prefix)) - ;; Need NO resizer. - (if (pair? (cdr windows)) - (pack-new! (cdr windows) grid #f prefix))))) + (if (pair? (cdr windows)) + (pack-new! (cdr windows) grid prefix)))) + (else (error "Unexpected Edwin window:" window))))) (main)) @@ -947,19 +888,17 @@ USA. (typein-frame (last (gtk-container-reverse-children top-grid)))) (any-child text-widget? typein-frame))) -(define (%reversed-children window) - ;; Produce a list of a combination window's children from right to - ;; left (or bottom to top). +(define (%children window) + ;; Produce a list of a combination window's children from left to right + ;; (or top to bottom). (cond ((editor-frame? window) - (list (editor-frame-typein-window window) - (editor-frame-root-window window))) + (list (editor-frame-root-window window) + (editor-frame-typein-window window))) ((combination? window) - (let loop ((child (combination-child window)) - (so-far '())) + (let loop ((child (combination-child window))) (if child - (loop (window-next child) - (cons child so-far)) - so-far))) + (cons child (loop (window-next child))) + '()))) (else (error "Unexpected Edwin window:" window)))) (define-integrable (%text-x-size window) @@ -1042,6 +981,8 @@ USA. (call-next-method widget (x-size->width screen x-size) (y-size->height screen y-size))) + (gtk-widget-set-hexpand widget #t) + (gtk-widget-set-vexpand widget #t) (let ((drawing (make-fix-drawing))) ;;; (%trace "; drawing: "drawing"\n") (let ((ink (make-simple-text-ink))) @@ -1095,7 +1036,7 @@ USA. (set-gtk-widget-bg-color! widget "white")) (define-method fix-widget-new-geometry-callback ((widget )) - (%trace ";(fix-widget-new-geometry-callback ) "widget"\n") + (%trace "; (fix-widget-new-geometry-callback ) "widget"\n") (call-next-method widget) (thread-queue/queue-no-hang! event-queue @@ -1110,8 +1051,8 @@ USA. (widget-y-size (height->y-size screen (fix-rect-height geometry))) (window-x-size (%text-x-size window)) (window-y-size (%text-y-size window))) - (%trace "; "widget": "geometry"\n") - (%trace "; "window": "window-x-size"x"window-y-size"\n") + (%trace "; "widget": "geometry"\n") + (%trace "; "window": "window-x-size"x"window-y-size"\n") (if (not (and (fix:= widget-x-size window-x-size) (fix:= widget-y-size window-y-size))) (update-sizes screen))))) @@ -1198,7 +1139,7 @@ USA. (%set-inferior-start! inferior x y) (if (or (editor-frame? window) (combination? window)) - (%set-starts! (reverse! (%reversed-children window)) window + (%set-starts! (%children window) window (string-append prefix "--") x y)) (if (or (editor-frame? parent) @@ -1222,7 +1163,7 @@ USA. (%trace "; screen: "x-size"x"y-size"\n") (set-screen-x-size! screen x-size) (set-screen-y-size! screen y-size)) - (%set-starts! (reverse! (%reversed-children root)) root "--" 0 0))) + (%set-starts! (%children root) root "--" 0 0))) (define-integrable (editor-frame? object) (object-of-class? editor-frame object)) @@ -1233,18 +1174,11 @@ USA. (define-method initialize-instance ((widget )) ;;; (%trace ";(initialize-instance ) "widget"\n") (let ((screen (edwin-widget-screen widget))) - (call-next-method widget -1 (y-size->height screen 1))) + (call-next-method widget 0 (y-size->height screen 1))) + (gtk-widget-set-hexpand widget #t) + (gtk-widget-set-vexpand widget #f) (let ((drawing (make-fix-drawing))) ;;; (%trace "; drawing: "drawing"\n") - (let ((ink (make-simple-text-ink))) - (set-simple-text-ink-text! - ink widget "--------Initial mode line.--------------------------------") - (set-text-ink-color! ink "white") - (fix-drawing-add-ink! drawing ink) - (let ((extent (fix-ink-extent ink))) - (set-fix-drawing-size! drawing - (fix-rect-width extent) - (fix-rect-height extent)))) (set-fix-layout-drawing! widget drawing 0 0)) (set-fix-widget-map-handler! widget map-handler) (set-fix-widget-unmap-handler! widget unmap-handler) @@ -1264,24 +1198,35 @@ USA. ;; something reasonable. (let ((screen (edwin-widget-screen widget))) (%trace "; uninitialized geometry: "geometry"\n") - (set-fix-rect-size! geometry -1 (y-size->height screen 1)) + (set-fix-rect-size! geometry 0 (y-size->height screen 1)) (%trace "; initialized geometry: "geometry"\n")))) (call-next-method widget) + (set-gtk-widget-bg-color! widget "black") (realize-font! widget) - (set-gtk-widget-bg-color! widget "black")) + (let ((ink (make-simple-text-ink)) + (drawing (fix-layout-drawing widget))) + (set-simple-text-ink-font! ink (gtk-screen-font + (edwin-widget-screen widget))) + (set-simple-text-ink-text! + ink widget "--------Initial mode line.--------------------------------") + (set-text-ink-color! ink "white") + (fix-drawing-add-ink! drawing ink) + (let ((extent (fix-ink-extent ink))) + (set-fix-drawing-size! drawing + (fix-rect-width extent) + (fix-rect-height extent))))) (define-class ( (constructor ())) () ;; This one just "marks" a gtk-container as the type that holds a - ;; text-widget and its modeline (and button bars?) together. If the - ;; frame has no modeline (nor button bars? :-) a lone scroller STILL - ;; gets wrapped. + ;; text-widget, modeline and button bars together. If the frame has + ;; no modeline nor buttons, a lone scroller STILL gets wrapped. ) (define-method initialize-instance ((widget )) ;;; (%trace ";(initialize-instance ) "widget"\n") - (call-next-method widget #f 0) + (call-next-method widget) (gtk-orientable-set-orientation widget 'vertical)) ;; Assume there is one text-widget in a buffer-frame-widget.