#| -*-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.
(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]+")
(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")
((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))
(%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))))
\f
;;; Initialization
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))
((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))
(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)
=> (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
(%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
(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)))
(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))
(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)
(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)))
(set-gtk-widget-bg-color! widget "white"))
(define-method fix-widget-new-geometry-callback ((widget <text-widget>))
- (%trace ";(fix-widget-new-geometry-callback <text-widget>) "widget"\n")
+ (%trace "; (fix-widget-new-geometry-callback <text-widget>) "widget"\n")
(call-next-method widget)
(thread-queue/queue-no-hang!
event-queue
(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)))))
(%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)
(%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))
(define-method initialize-instance ((widget <modeline-widget>))
;;; (%trace ";(initialize-instance <modeline-widget>) "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)
;; 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 (<buffer-frame-widget> (constructor ()))
(<gtk-grid>)
;; 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 <buffer-frame-widget>))
;;; (%trace ";(initialize-instance <buffer-frame-widget>) "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.
projects / mit-scheme.git / commitdiff