--- /dev/null
- (let ((top-box (gtk-vbox-new #f 0)))
- (gtk-container-add toplevel top-box)
- (%trace "; -init "root" in "top-box"\n")
+#| -*-Scheme-*-
+
+Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; A GTK-based <screen> for Edwin.
+;;; Package: (edwin screen gtk-screen)
+
+(define-class (<gtk-screen>
+ (constructor %make-gtk-screen (toplevel editor-thread) no-init))
+ (<screen>) ;; TODO: could also be a <gtk-window>, replacing toplevel!
+
+ ;; The toplevel <gtk-window>. The top widget.
+ (toplevel define accessor)
+
+ ;; The Edwin thread, used by event handlers (callbacks) running in
+ ;; the gtk-thread, where editor-thread is unassigned.
+ (editor-thread define accessor)
+
+ ;; An alist of Edwin buffers and their drawings, to be shared among
+ ;; the text-widgets, and updated during screen update.
+ (drawings define standard initial-value '())
+
+ ;; The window/icon/taskbar name. #f just means "not set". Cannot be
+ ;; set to #f!
+ (name define standard initial-value #f)
+
+ ;; The default font. Initially a string. Replaced with a
+ ;; PangoFontDescription when the toplevel has been realized.
+ (font define standard)
+
+ ;; The default font's character dimensions.
+ (char-width define standard)
+ (line-height define standard)
+ (line-spacing define standard)
+
+ ;; The thread that blinks the cursor and the blinking <cursor-ink>.
+ (blinker define standard)
+ (blinking define standard initial-value #f)
+
+ ;; Whether a cursor should be blinking.
+ (in-focus? define standard initial-value #f))
+
+(define screen-list)
+
+(define (make-gtk-screen #!optional geometry)
+ (%trace "; make-gtk-screen "geometry"\n")
+ (let* ((toplevel (gtk-window-new 'toplevel))
+ (screen (%make-gtk-screen toplevel (current-thread)))
+ (geometry* (if (default-object? geometry)
+ "80x24"
+ (begin
+ (guarantee-string geometry 'make-gtk-screen)
+ geometry))))
+ (gtk-window-set-opacity toplevel 0.95)
+ (set-gtk-screen-font! screen "Monospace 11")
+ (init-font-dimensions! screen)
+ (init-size! screen geometry*)
+ (let ((thread (create-blinker-thread screen)))
+ (%trace "; blinker thread: "thread"\n")
+ (set-gtk-screen-blinker! screen thread)
+ (detach-thread thread)
+ (%trace "; editor thread: "(current-thread)"\n"))
+ (set! screen-list (cons screen screen-list))
+ (%trace "; screen: "screen"\n")
+ screen))
+
+(define (init-font-dimensions! screen)
+ (%trace "; init-font-dimensions! "screen"\n")
+ ;; Lookup SCREEN's font via the toplevel widget's pango-context,
+ ;; which appears to be available before toplevel is realized.
+
+ (let* ((spec (gtk-screen-font screen))
+ (toplevel (gtk-screen-toplevel screen))
+ (context (gtk-widget-get-pango-context toplevel))
+ (font (pango-font-description-from-string spec))
+ (metrics (pango-context-get-metrics context font)))
+ (pango-font-description-free font)
+ (let ((ascent (pangos->pixels (pango-font-metrics-get-ascent metrics)))
+ (descent (pangos->pixels (pango-font-metrics-get-descent metrics)))
+ (width (pangos->pixels
+ (pango-font-metrics-get-approximate-char-width metrics)))
+ (spacing (pangos->pixels (pango-context-spacing context))))
+ (if (zero? width)
+ (error "could not get metrics for font" spec))
+ (set-gtk-screen-char-width! screen width)
+ (set-gtk-screen-line-spacing! screen spacing)
+ (set-gtk-screen-line-height! screen (fix:+ ascent descent))
+ (%trace "; Font: \""spec"\" "width"x"ascent"+"descent" "spacing"\n")
+ (pango-font-metrics-unref metrics))))
+
+(define (realize-font! widget)
+ (let* ((screen (edwin-widget-screen widget))
+ (font (gtk-screen-font screen)))
+ (if (string? font)
+ (let ((desc (pango-font-description-from-string font)))
+ (%trace "; realize-font!\n")
+ (set-gtk-widget-font! (gtk-screen-toplevel screen) desc)
+ (set-gtk-widget-font! widget desc)
+ (set-gtk-screen-font! screen desc))
+ (set-gtk-widget-font! widget font))))
+
+(define (init-size! screen geometry)
+ (%trace "; init-size! "screen" "geometry"\n")
+ ;; Sets the logical screen size. This sets Edwin window and thus
+ ;; text-widget sizes, which ultimately determine the GtkWindow size
+ ;; request. Sets a small (arbitrary) minimum size so that the luser
+ ;; can resize to a size smaller than the logical size.
+ (parse-geometry
+ geometry
+ (lambda (width height x y)
+ (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)))))))
+
+(define (parse-geometry geometry receiver)
+ (let* ((num "[0-9]+")
+ (size-patt (string "\\("num"\\)x\\("num"\\)"))
+ (position-patt (string "\\([-+]"num"\\)\\([-+]"num"\\)"))
+ (extract (lambda (regs index)
+ (string->number (re-match-extract geometry regs index)))))
+ (declare (integrate extract))
+ (cond ((re-string-match (string size-patt position-patt) geometry)
+ => (lambda (regs)
+ (receiver (extract regs 1) (extract regs 2)
+ (extract regs 3) (extract regs 4))))
+ ((re-string-match position-patt geometry)
+ => (lambda (regs)
+ (receiver #f #f
+ (extract regs 1) (extract regs 2))))
+ ((re-string-match size-patt geometry)
+ => (lambda (regs)
+ (receiver (extract regs 1) (extract regs 2)
+ #f #f)))
+ (else
+ (error:wrong-type-argument geometry
+ "window geometry (e.g. \"80x40-0-0\")"
+ 'parse-geometry)))))
+
+(define (x-size->width screen x-size)
+ (fix:* x-size (gtk-screen-char-width screen)))
+
+(define (y-size->height screen y-size)
+ (fix:+ (fix:* y-size (gtk-screen-line-height screen))
+ (fix:* (fix:1+ y-size) (gtk-screen-line-spacing screen))))
+
+(define (width->x-size screen width)
+ (fix:quotient width (gtk-screen-char-width screen)))
+
+(define (height->y-size screen height)
+ (let ((line-spacing (gtk-screen-line-spacing screen))
+ (line-height (gtk-screen-line-height screen)))
+ (fix:quotient (fix:- height line-spacing)
+ (fix:+ line-height line-spacing))))
+
+(define (column->x screen column)
+ (fix:* column (gtk-screen-char-width screen)))
+
+(define (row->y screen row)
+ (fix:* row (fix:+ (gtk-screen-line-spacing screen)
+ (gtk-screen-line-height screen))))
+
+(define (window-text-widget* window)
+ (any-child (lambda (widget)
+ (and (text-widget? widget)
+ (eq? window (text-widget-buffer-frame widget))))
+ (gtk-screen-toplevel (window-screen window))))
+
+(define-integrable (window-modeline* window)
+ (let ((widget (window-text-widget* window)))
+ (and widget (text-widget-modeline widget))))
+
+(define-integrable (window-cursor-ink* window)
+ (let ((widget (window-text-widget* window)))
+ (and widget (text-widget-cursor-ink widget))))
+
+(define-integrable (selected-text-widget* screen)
+ (let ((window (screen-cursor-window screen)))
+ (and window (window-text-widget* window))))
+
+(define-integrable (car* obj) (and (pair? obj) (car obj)))
+
+(define-integrable (cdr* obj) (and (pair? obj) (cdr obj)))
+
+(define-method set-screen-size! ((screen <gtk-screen>) x-size y-size)
+ (%trace "; (set-screen-size! <gtk-screen>) "screen" "x-size"x"y-size"\n")
+ (without-interrupts
+ (lambda ()
+ (set-screen-x-size! screen x-size)
+ (set-screen-y-size! screen y-size)
+ (send (screen-root-window screen) ':set-size! x-size y-size))))
+
+(define %trace-blinker? #f)
+
+(define (create-blinker-thread screen)
+
+ (define-syntax %trace3
+ (syntax-rules ()
+ ((_ ARGS ...) (if %trace-blinker? (outf-error ARGS ...)))))
+
+ (create-thread
+ #f
+ (lambda ()
+ (%trace2 ";blinking started on "screen"\n")
+ (let loop ()
+ (without-interrupts
+ (lambda ()
+ (let ((cursor (gtk-screen-blinking screen)))
+ (cond ((not cursor)
+ (%trace2 ";blinker: no blinking "screen"\n")
+ (suspend-current-thread)
+ (%trace2 ";blinker: awake after not blinking "screen"\n"))
+ ((not (cursor-ink-visible? cursor))
+ (%trace2 ";blinker: invisible "cursor"\n")
+ (suspend-current-thread)
+ (%trace2 ";blinker: awake after invisible "cursor"\n"))
+ (else
+ (%trace3 ";blinker: off "cursor"\n")
+ (set-fix-ink-widgets! cursor '())
+ (sleep-current-thread 500)
+ (if (cursor-ink-visible? cursor)
+ (begin
+ (%trace3 ";blinker: on "cursor"\n")
+ (set-fix-ink-widgets! cursor
+ (cursor-ink-widget-list cursor))
+ (sleep-current-thread 500))
+ (begin
+ (%trace ";blinker: on: invisible "cursor"\n")
+ unspecific)))))))
+ (loop)))))
+\f
+(define-method screen-beep ((screen <gtk-screen>))
+ (gtk-widget-error-bell (gtk-screen-toplevel screen)))
+
+(define-method screen-enter! ((screen <gtk-screen>))
+ (%trace "; screen-enter! "screen"\n")
+ (update-widgets screen)
+ (gtk-window-present (gtk-screen-toplevel screen))
+ (%trace "; screen-enter!: done\n"))
+
+(define-method screen-exit! ((screen <gtk-screen>))
+ (%trace "; screen-exit! "screen"\n")
+ (set-gtk-screen-in-focus?! screen #f)
+ (update-blinking screen))
+
+(define-method screen-discard! ((screen <gtk-screen>))
+ (set! screen-list (delq! screen screen-list))
+ (gtk-widget-destroy (gtk-screen-toplevel screen)))
+
+(define-method screen-modeline-event! ((screen <gtk-screen>) window type)
+ (%trace "; screen-modeline-event! "screen" "window" "type"\n"))
+\f
+;;; These scrolling procedures are for editor commands (not
+;;; scrollbars). They force a buffer-drawing layout update
+;;; (effectively, a redisplay) after which they can map window coords
+;;; to drawing coords to line ink to buffer index.
+
+(define-method screen/window-scroll-y-absolute! ((screen <gtk-screen>)
+ frame y-point)
+ (%trace "; screen/window-scroll-y-absolute! "screen" "frame" "y-point"\n")
+ (with-updated-window
+ screen frame 'SCROLL-Y-ABSOLUTE!
+ (lambda (widget)
+ (let ((cursor (text-widget-cursor-ink widget))
+ (view (fix-layout-view widget)))
+ (let ((desired-y (fix:+ (fix-rect-y view)
+ (row->y screen y-point)))
+ (actual-y (fix-rect-y (fix-ink-extent cursor))))
+ (%scroll-to screen widget
+ (fix-rect-x view)
+ (fix:+ (fix:- actual-y desired-y)
+ (fix-rect-y view))))))))
+
+(define (%scroll-to screen widget x y)
+ (let* ((max-y (let ((drawing (text-widget-buffer-drawing widget)))
+ (if drawing
+ (fix:max 0
+ (fix:- (fix-rect-max-y
+ (fix-drawing-extent drawing))
+ (gtk-screen-line-height screen)))
+ 0)))
+ (y* (fix:min max-y (fix:max 0 y))))
+ (%trace "; %scroll-to "x" "y*"\n")
+ (fix-layout-scroll-to! widget x y*)
+ (update-start-mark widget)))
+
+(define (with-updated-window screen frame what operation)
+ (%trace "; with-updated-window "screen" "frame" "what"\n")
+
+ (if (not (screen-in-update? screen))
+ ;; Don't loop when used during screen update(!).
+ (begin
+ (%trace "; forcing update...\n")
+ (update-screens! #t)
+ (%trace "; ...forced update finished.\n"))
+ (%trace "; in update, with widget "(window-text-widget* frame)"\n"))
+
+ (let ((widget (window-text-widget* frame)))
+ (if (not widget) (error "No widget:" frame))
+ (operation widget)))
+
+(define-method screen/window-scroll-y-relative! ((screen <gtk-screen>)
+ frame delta)
+ (%trace "; screen/window-scroll-y-relative! "screen" "frame" "delta"\n")
+ (with-updated-window
+ screen frame 'SCROLL-Y-RELATIVE!
+ (lambda (widget)
+ (let ((view (fix-layout-view widget))
+ (delta* (row->y screen delta)))
+ (%scroll-to screen widget
+ (fix-rect-x view)
+ (fix:+ delta* (fix-rect-y view)))
+ (update-point widget)))))
+
+(define-method screen/set-window-start-mark! ((screen <gtk-screen>)
+ frame mark force?)
+ (%trace "; screen/set-window-start-mark! "screen" "frame" "mark" "force?"\n")
+ (with-updated-window
+ screen frame 'SET-START-MARK!
+ (lambda (widget)
+ (let ((view (fix-layout-view widget))
+ (line (find-line-at mark widget)))
+ (let ((x (fix-rect-x view))
+ (y (if line
+ (fix:- (fix-rect-y (fix-ink-extent line))
+ (gtk-screen-line-spacing screen))
+ 0)))
+ (cond (force?
+ (fix-layout-scroll-to! widget x y)
+ (update-start-mark widget)
+ (update-point widget))
+ ((let ((extent (fix-ink-extent (text-widget-cursor-ink widget))))
+ (and (fix:<= y
+ (fix-rect-min-y extent))
+ (fix:< (fix-rect-min-y extent)
+ (fix:+ y (fix-rect-height view)))))
+ (fix-layout-scroll-to! widget x y)
+ (update-start-mark widget))))))))
+
+(define-method screen/window-mark-visible? ((screen <gtk-screen>) frame mark)
+ (%trace "; screen/window-mark-visible? "screen" "frame" "mark"\n")
+ (with-updated-window
+ screen frame 'MARK-VISIBLE?
+ (lambda (widget)
+ (let ((view (fix-layout-view widget))
+ (line (find-line-at mark widget)))
+ (let ((min-y (if line
+ (fix-rect-min-y (fix-ink-extent line))
+ 0)))
+ (if (and (fix:<= (fix-rect-min-y view)
+ min-y)
+ (fix:< min-y
+ (fix-rect-max-y view)))
+ (begin
+ (%trace "; visible\n")
+ #t)
+ (begin
+ (%trace "; NOT visible\n")
+ #f)))))))
+
+(define-method screen/window-mark->x ((screen <gtk-screen>) frame mark)
+ (%trace "; screen/window-mark->x "screen" "frame" "mark"\n")
+ 0 ; Need a real X???
+ )
+
+(define-method screen/window-mark->y ((screen <gtk-screen>) frame mark)
+ (%trace "; screen/window-mark->y "screen" "frame" "mark"\n")
+ (with-updated-window
+ screen frame 'MARK->Y
+ (lambda (widget)
+ (line->row screen widget (find-line-at mark widget)))))
+
+(define-integrable (line->row screen widget line)
+ (let* ((view (fix-layout-view widget))
+ (spacing (gtk-screen-line-spacing screen))
+ (height (gtk-screen-line-height screen))
+ (y (if (not line)
+ 0
+ (fix-rect-y (fix-ink-extent line)))))
+ (fix:quotient (fix:- y (fix-rect-y view))
+ (fix:+ height spacing))))
+
+(define-method screen/window-mark->coordinates ((screen <gtk-screen>)
+ frame mark)
+ (%trace "; screen/window-mark->coordinates "screen" "frame" "mark"\n")
+ (with-updated-window
+ screen frame 'MARK->COORDINATES
+ (lambda (widget)
+ (let ((line (find-line-at mark widget)))
+ (cons
+ 0 ; Need a real X???
+ (line->row screen widget line))))))
+
+(define-method screen/window-point-x ((screen <gtk-screen>) frame)
+ (screen/window-mark->x screen frame (window-point frame)))
+
+(define-method screen/window-point-y ((screen <gtk-screen>) frame)
+ (screen/window-mark->y screen frame (window-point frame)))
+
+(define-method screen/window-point-coordinates ((screen <gtk-screen>) frame)
+ (screen/window-mark->coordinates screen frame (window-point frame)))
+
+(define-method screen/window-coordinates->mark ((screen <gtk-screen>)
+ frame x y)
+ (%trace "; screen/window-coordinates->mark "screen" "frame" "x" "y"\n")
+ (with-updated-window
+ screen frame 'COORDINATES->MARK
+ (lambda (widget)
+ (let* ((y* (fix:+ (row->y screen y)
+ (fix-rect-y (fix-layout-view widget))))
+ (line (find-line-after y* widget)))
+ (%trace "; line at "y*": "line"\n")
+ (mark-temporary-copy (line-start line widget))))))
+
+(define-integrable (update-start-mark widget)
+ ;; Set WIDGET's window's start-mark to the start of the first
+ ;; completely visible line ink.
+ (let ((line (find-line-after (fix-rect-y (fix-layout-view widget)) widget)))
+ (move-mark-to! (get-start-mark widget)
+ (line-start line widget))))
+
+(define-integrable (get-start-mark widget)
+ (let ((window (frame-text-inferior (text-widget-buffer-frame widget))))
+ (or (%window-start-mark window)
+ (let ((new (mark-permanent-copy (no-line-start widget))))
+ (%set-window-start-mark! window new)
+ new))))
+
+(define-integrable (no-line-start widget)
+ (buffer-drawing-display-start (fix-layout-drawing widget)))
+
+(define (update-point widget)
+ (%trace "; update-point "widget"\n")
+ ;; Move WIDGET's window's point into view at the beginning of the
+ ;; nearest (first or last) completely visible line.
+
+ (define-integrable (move-point for/back line)
+ (let ((window (frame-text-inferior (text-widget-buffer-frame widget))))
+ (%trace "; "for/back"ward to "line"\n")
+ (%set-window-point-index! window
+ (mark-index (line-start line widget)))
+ (%set-window-point-moved?! window #t)
+ (update-cursor widget)))
+
+ (let ((extent (fix-ink-extent (text-widget-cursor-ink widget)))
+ (view (fix-layout-view widget)))
+ (cond ((fix:< (fix-rect-min-y extent)
+ (fix-rect-min-y view))
+ (move-point 'for (find-line-after (fix-rect-min-y view) widget)))
+ ((fix:< (fix-rect-max-y view)
+ (fix-rect-max-y extent))
+ (move-point 'back (find-line-before (fix-rect-max-y view) widget)))
+ (else
+ (%trace "; no need to move\n")))))
+
+(define-integrable (line-start line widget)
+ (if line
+ (line-ink-start line)
+ (no-line-start widget)))
+
+(define (find-line-at point widget)
+ ;; Return the line-ink that includes the character at POINT. If
+ ;; there is no such line, return #f or the last line found.
+ (let loop ((inks (fix-drawing-display-list
+ (fix-layout-drawing widget)))
+ (last #f))
+ (cond ((null? inks) last)
+ ((not (line-ink? (car inks)))
+ (loop (cdr inks) last))
+ (else
+ (let ((line (car inks)))
+ (if (mark< point (line-ink-end line))
+ line
+ (loop (cdr inks) line)))))))
+
+(define (find-line-after y widget)
+ ;; Find the first line-ink that starts at or below Y, or the last
+ ;; (closest) line. Returns #f when the buffer is empty.
+ (let loop ((inks (fix-drawing-display-list (fix-layout-drawing widget)))
+ (previous #f))
+ (if (pair? inks)
+ (let ((ink (car inks)))
+ (if (line-ink? ink)
+ (if (fix:<= y (fix-rect-y (fix-ink-extent ink)))
+ ink
+ (loop (cdr inks) ink))
+ (loop (cdr inks) previous)))
+ previous)))
+
+(define (find-line-before y widget)
+ ;; Find the last line-ink that ends at or above Y. Returns #f when
+ ;; the buffer is empty.
+ (let loop ((inks (fix-drawing-display-list (fix-layout-drawing widget)))
+ (previous #f))
+ (if (pair? inks)
+ (let ((ink (car inks)))
+ (if (line-ink? ink)
+ (if (fix:< y (fix-rect-max-y (fix-ink-extent ink)))
+ previous
+ (loop (cdr inks) ink))
+ (loop (cdr inks) previous)))
+ previous)))
+\f
+;;; Event Handling
+
+(define event-queue)
+(define change-event-registration)
+
+(define (get-gtk-input-operations)
+ (values
+ (lambda () ;halt-update?
+ ;; Large buffers will generate large runs of these traces...
+ ;;(%trace2 ";halt-update?")
+ (let ((halt? (not (thread-queue/empty? event-queue))))
+ ;;(%trace2 " => "halt?"\n")
+ halt?))
+ (lambda (msec) ;peek-no-hang
+ (%trace2 ";peek-no-hang "msec"\n")
+ (let ((event (thread-queue/peek-no-hang event-queue msec)))
+ (%trace2 ";peek-no-hang "msec" => "event"\n")
+ event))
+ (lambda () ;peek
+ (%trace2 ";peek\n")
+ (let ((event (thread-queue/peek event-queue)))
+ (%trace2 ";peek => "event"\n")
+ event))
+ (lambda () ;read
+ (%trace2 ";read\n")
+ (let ((event (thread-queue/dequeue! event-queue)))
+ (%trace2 ";read => "event"\n")
+ event))))
+
+(define (gtk-screen-inferior-thread-output)
+ ;; Invoked via hook/signal-inferior-thread-output!.
+ (thread-queue/queue-no-hang!
+ event-queue (make-input-event 'UPDATE gtk-screen-accept-thread-output)))
+
+(define (gtk-screen-accept-thread-output)
+ (if (accept-thread-output)
+ (update-screens! #f)))
+
+(define (gtk-screen-inferior-process-output)
+ ;; Invoked via hook/inferior-process-output.
+ (thread-queue/queue-no-hang!
+ event-queue (make-input-event 'UPDATE gtk-screen-accept-process-output)))
+
+(define (gtk-screen-accept-process-output)
+ (if (accept-process-output)
+ (update-screens! #f)))
+
+(define (gtk-screen-process-status-change)
+ ;; Invoked by a thread-event (asynchronously) whenever ANY
+ ;; subprocess status changes.
+ (thread-queue/queue-no-hang!
+ event-queue
+ (make-input-event 'UPDATE gtk-screen-accept-process-status-change)))
+
+(define (gtk-screen-accept-process-status-change)
+ (if (handle-process-status-changes)
+ (update-screens! #f)))
+
+(define interrupts?)
+
+(define (interrupt!)
+ (%trace ";interrupt!...")
+ (if interrupts?
+ (begin
+ (%trace " signaling.\n")
+ (editor-beep)
+ (temporary-message "Quit")
+ (^G-signal))
+ (%trace " masked!\n")))
+
+(define (with-editor-interrupts-from-gtk receiver)
+ (fluid-let ((interrupts? #t))
+ (%trace ";with-editor-interrupts-from-gtk "(current-thread)"\n")
+ (receiver (lambda (thunk) (thunk)) '())))
+
+(define (with-gtk-interrupts-enabled thunk)
+ (fluid-let ((interrupts? #t))
+ (%trace ";with-gtk-interrupts-enabled\n")
+ (let ((v (thunk)))
+ (%trace ";with-gtk-interrupts-enabled => "v"\n")
+ v)))
+
+(define (with-gtk-interrupts-disabled thunk)
+ (fluid-let ((interrupts? #f))
+ (%trace ";with-gtk-interrupts-disabled\n")
+ (let ((v (thunk)))
+ (%trace ";with-gtk-interrupts-disabled => "v"\n")
+ v)))
+
+(define (map-handler widget)
+ (%trace "; Mapped: "widget"\n")
+ 0 ;;Continue.
+ )
+
+(define (unmap-handler widget)
+ (%trace "; Unmapped: "widget"\n")
+ 0 ;;Continue.
+ )
+
+(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.
+ )
+
+(define (visibility-notify-handler widget state)
+ (%trace "; Visibility: "state" "widget"\n")
+ (let ((screen (edwin-widget-screen widget)))
+ (case state
+ ((VISIBLE) (set-screen-visibility! screen 'VISIBLE))
+ ((PARTIALLY-OBSCURED) (set-screen-visibility! screen 'PARTIALLY-OBSCURED))
+ ((OBSCURED) (set-screen-visibility! screen 'OBSCURED))
+ (else (warn "unexpected visibility state:" state))))
+ 1 ;;Handled.
+ )
+
+(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.
+ ))
+ (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)
+ #f)
+ (else key))))
+ (if (char? k)
+ (if (char=? k #\BEL)
+ (let* ((screen (edwin-widget-screen widget))
+ (thread (gtk-screen-editor-thread screen)))
+ (%trace "; pushing ^G in "(current-thread)"...\n")
+ (thread-queue/push! event-queue #\BEL)
+ (%trace "; signaling "thread"\n")
+ (signal-thread-event
+ thread
+ (lambda ()
+ (%trace ";interrupt! in editor "(current-thread)"\n")
+ (interrupt!)))
+ (%trace "; pushed ^G in "(current-thread)".\n")
+ 1 ;;Handled.
+ )
+ (queue! (merge-bucky-bits k char-bits)))
+ (if k
+ (queue! (make-special-key k char-bits))
+ 1 ;;Handled.
+ ))))
+\f
+;;; Initialization
+
+(define gtk-display-type)
+
+(define (set-gtk-screen-hooks!)
+ (set! hook/signal-inferior-thread-output! gtk-screen-inferior-thread-output)
+ (set! hook/inferior-process-output gtk-screen-inferior-process-output))
+
+(define (initialize-package!)
+ (set! screen-list '())
+ (set! event-queue (make-thread-queue 128))
+ (set! change-event-registration ;deregister when???
+ (register-subprocess-status-change-event
+ (lambda (mode)
+ (declare (ignore mode))
+ (gtk-screen-process-status-change))))
+ (set! gtk-display-type
+ (make-display-type 'GTK
+ #t
+ gtk-thread-running?
+ make-gtk-screen
+ (lambda (screen)
+ screen ;ignore
+ (get-gtk-input-operations))
+ with-editor-interrupts-from-gtk
+ with-gtk-interrupts-enabled
+ with-gtk-interrupts-disabled))
+ unspecific)
+\f
+(define (update-widgets screen)
+ (%trace "; update-widgets "screen"\n")
+
+ (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)
- '() top-box #f "--")
++ (let ((top-grid (let ((g (gtk-grid-new)))
++ (gtk-orientable-set-orientation g 'VERTICAL)
++ ;; homogenous: #f spacing: 0
++ g)))
++ (gtk-container-add toplevel top-grid)
++ (%trace "; -init "root" in "top-grid"\n")
+ (re-pack-windows! (%reversed-children root)
- (let ((top-box (car top-children)))
- (%trace "; -pack "root" into "top-box"\n")
++ '() top-grid #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"))
- (gtk-container-children top-box) top-box #f "--")
++ (let ((top-grid (car top-children)))
++ (%trace "; -pack "root" into "top-grid"\n")
+ (re-pack-windows! (%reversed-children root)
- (define (re-pack-windows! windows widgets box resizer prefix)
++ (gtk-container-children top-grid)
++ top-grid #f "--")
+ (for-each-text-widget screen update-widget-buffer)
+ (%trace "; -show-all "toplevel"\n")
+ (gtk-widget-show-all toplevel)
+ (%trace "; update-widgets done\n")))))
+
- (pack-new! windows box resizer prefix))
++ (define (re-pack-windows! windows widgets grid 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-widget-destroy child))
+ widgets)
+ (%trace "; "prefix"done, tossed extra children\n"))
+
+ ((not (pair? widgets))
+ ;; and (pair? windows) -- insufficient children
- (gtk-vbox? widget)
- (gtk-hbox? widget)))
++ (pack-new! windows grid 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)
- (re-pack-resizer! windows widgets box resizer prefix))
++ (and (gtk-grid? widget)
++ (eq? 'VERTICAL
++ (gtk-orientable-get-orientation widget)))
++ (and (gtk-grid? widget)
++ (eq? 'HORIZONTAL
++ (gtk-orientable-get-orientation 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)))
++ (re-pack-resizer! windows widgets grid 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-windows! windows (cdr widgets) box resizer prefix)))))))
++ (re-pack-resizer! windows widgets grid 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-widget-destroy widget)
- (define (re-pack-resizer! windows widgets box resizer prefix)
++ (re-pack-windows! windows (cdr widgets) grid resizer prefix)))))))
+
- (if (and (gtk-hbox? box) (pair? (cdr windows)))
++ (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)))
+
- (re-pack-windows! (cdr windows) (cddr widgets) box resizer prefix)
++ (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
- (set-fix-resizer-after! new box)
- (gtk-box-pack-end box new #f #f 0)
++ (re-pack-windows! (cdr windows) (cddr widgets)
++ grid resizer prefix)
+ (let ((new (make-fix-resizer (gtk-screen-char-width screen) -1)))
- (re-pack-windows! (cdr windows) '() box new prefix))))
++ (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) (cdr widgets) box #f prefix)))
++ (re-pack-windows! (cdr windows) '() grid new prefix))))
+ ;; Need NO resizer.
- (define (pack-new! windows box resizer prefix)
++ (re-pack-windows! (cdr windows) (cdr widgets) grid #f prefix)))
+
+ (define (re-size! widget window)
+ (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")
+ (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")
+ (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" "
+ "("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))))))))
+
- (%trace "; "prefix"pack-new! "window" in "box"\n")
++ (define (pack-new! windows grid resizer prefix)
+ (let ((window (car windows)))
- (let ((new (if (combination-vertical? window)
- (gtk-vbox-new #f 0)
- (gtk-hbox-new #f 0)))
++ (%trace "; "prefix"pack-new! "window" in "grid"\n")
+ (cond
+ ((combination? window)
- (gtk-box-pack-end box new #t #t 0)
- (%trace "; "prefix"packed "new" in "box"\n")
++ (let ((new (gtk-grid-new))
+ (new-prefix (string-append prefix "--")))
++ (if (combination-vertical? window)
++ (begin
++ (gtk-orientable-set-orientation new 'vertical)
++ (gtk-widget-set-vexpand new #t))
++ (begin
++ (gtk-orientable-set-orientation new 'horizontal)
++ (gtk-widget-set-hexpand new #t)))
+ (pack-new! (%reversed-children (car windows)) new #f new-prefix)
- (if (and (gtk-hbox? box) (pair? (cdr windows)))
++ (gtk-container-add grid new)
++ (%trace "; "prefix"packed "new" in "grid"\n")
+ (if resizer (set-fix-resizer-before! resizer new))
- (gtk-box-pack-end box new-resizer #f #f 0)
- (pack-new! (cdr windows) box new-resizer prefix))
++ (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)
- (pack-new! (cdr windows) box #f prefix)))))
++ (gtk-container-add grid new-resizer)
++ (pack-new! (cdr windows) grid new-resizer prefix))
+ ;; Need NO resizer.
+ (if (pair? (cdr windows))
- (let ((vbox (make-buffer-frame-widget))
++ (pack-new! (cdr windows) grid #f prefix)))))
+
+ ((buffer-frame? window)
- (gtk-container-add scroller text)
++ (let ((vgrid (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)
- ;; 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.
+ (if (not modeline)
+ ;; No modeline: the window/text-widget should NOT 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-before! resizer vbox))
- (if (and (gtk-hbox? box) (pair? (cdr windows)))
++ (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
- (set-fix-resizer-after! new-resizer vbox)
- (gtk-box-pack-end box new-resizer #f #f 0)
- (pack-new! (cdr windows) box new-resizer prefix))
++ (gtk-widget-set-vexpand text #t)
++ (gtk-container-add scroller text)
++ (gtk-container-add vgrid modeline)
++ (gtk-container-add vgrid scroller)
++ (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)))
- (pack-new! (cdr windows) box #f prefix)))))
++ (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))
- (let* ((top-box (car (gtk-container-reverse-children
- (gtk-screen-toplevel screen))))
++ (pack-new! (cdr windows) grid #f prefix)))))
+ (else (error "Unexpected Edwin window:" window)))))
+
+ (main))
+
+(define-integrable (typein-widget screen)
- (typein-frame (last (gtk-container-reverse-children top-box))))
++ (let* ((top-grid (car (gtk-container-reverse-children
++ (gtk-screen-toplevel screen))))
+ ;; Typein widget is always added first -- last in the reverse list.
- (<gtk-vbox>)
++ (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).
+ (cond ((editor-frame? window)
+ (list (editor-frame-typein-window window)
+ (editor-frame-root-window window)))
+ ((combination? window)
+ (let loop ((child (combination-child window))
+ (so-far '()))
+ (if child
+ (loop (window-next child)
+ (cons child so-far))
+ so-far)))
+ (else (error "Unexpected Edwin window:" window))))
+
+(define-integrable (%text-x-size window)
+ (%window-x-size (frame-text-inferior window)))
+
+(define-integrable (%text-y-size window)
+ (%window-y-size (frame-text-inferior window)))
+
+(define-integrable (%widget-x-size window screen)
+ (x-size->width screen (%text-x-size window)))
+
+(define-integrable (%widget-y-size window screen)
+ (y-size->height screen (%text-y-size window)))
+
+(define (for-each-text-widget screen procedure)
+ (every-child (lambda (widget)
+ (and (text-widget? widget)
+ (procedure widget))
+ #t)
+ (gtk-screen-toplevel screen)))
+
+(define (every-text-widget screen predicate)
+ ;; Returns #t iff PREDICATE returns #t for every text widget on the
+ ;; screen.
+ (every-child (lambda (widget)
+ (or (not (text-widget? widget))
+ (predicate widget)))
+ (gtk-screen-toplevel screen)))
+
+(define (any-text-widget container)
+ (any-child text-widget? container))
+
+(define (any-child predicate container)
+ (let loop ((children (gtk-container-reverse-children container)))
+ (cond ((null? children) #f)
+ ((predicate (car children)) (car children))
+ ((gtk-container? (car children))
+ (or (loop (gtk-container-reverse-children (car children)))
+ (loop (cdr children))))
+ (else
+ (loop (cdr children))))))
+
+(define (every-child predicate container)
+ (let loop ((children (gtk-container-reverse-children container)))
+ (cond ((null? children) #t)
+ ((gtk-container? (car children))
+ (and (loop (gtk-container-reverse-children (car children)))
+ (loop (cdr children))))
+ ((predicate (car children)) (loop (cdr children)))
+ (else #f))))
+\f
+;;; Text and Modeline Widgets
+
+(define-class <edwin-widget>
+ (<fix-layout>)
+
+ (screen define standard))
+
+(define-class (<text-widget>
+ (constructor make-text-widget (screen) (x-size y-size)))
+ (<edwin-widget>)
+
+ (override-drawing define standard)
+ (buffer-drawing define standard initial-value #f)
+
+ ;; Scroll pos for buffer-drawing, saved while override-drawing is up.
+ (text-pos define standard initializer (lambda () (cons 0 0)))
+
+ (buffer-frame define standard)
+ (modeline define standard initial-value #f)
+ (cursor-ink define standard initial-value #f)
+ (start-mark define standard initial-value #f))
+
+(define-guarantee text-widget "a <text-widget>")
+
+(define-method initialize-instance ((widget <text-widget>) x-size y-size)
+;;; (%trace ";(initialize-instance <text-widget>) "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")
+ (let ((ink (make-simple-text-ink)))
+ (set-simple-text-ink-text! ink widget "Initial override message.")
+ (set-text-ink-color! ink "black")
+ (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-text-widget-override-drawing! widget drawing)
+ (set-fix-layout-drawing! widget drawing 0 0))
+ (set-fix-widget-map-handler! widget map-handler)
+ (set-fix-widget-unmap-handler! widget unmap-handler)
+ (set-fix-widget-focus-change-handler! widget focus-change-handler)
+ (set-fix-widget-visibility-notify-handler! widget visibility-notify-handler)
+ (set-fix-widget-key-press-handler! widget key-press-handler)
+ widget)
+
+(define-method gtk-widget-destroy-callback ((widget <text-widget>))
+ ;; NOTE that this callback can be called before a widget is realized(!).
+ (call-next-method widget)
+ (let ((cursor (text-widget-cursor-ink widget)))
+ (if cursor
+ (fix-ink-remove! cursor)))
+ (and-let* ((drawing (text-widget-override-drawing widget))
+ (ink (car (fix-drawing-display-list drawing)))
+ ((text-ink? ink))
+ (layout (text-ink-pango-layout ink)))
+ (gobject-unref! layout))
+ unspecific)
+
+(define-method fix-widget-realize-callback ((widget <text-widget>))
+ (%trace ";(fix-widget-realize-callback <text-widget>) "widget"\n")
+ (let ((geometry (fix-widget-geometry widget)))
+ (if (or (not (fix-rect-width geometry))
+ (not (fix-rect-height geometry)))
+ ;; Unfortunately a widget can be realized before it is
+ ;; allocated a size -- when it is added to a realized
+ ;; container. In this case, initialize WIDGET's size to
+ ;; something reasonable.
+ (let ((window (text-widget-buffer-frame widget))
+ (screen (edwin-widget-screen widget)))
+ (%trace "; uninitialized geometry: "geometry"\n")
+ (set-fix-rect-size! geometry
+ (%widget-x-size window screen)
+ (%widget-y-size window screen))
+ (%trace "; initialized geometry: "geometry"\n"))))
+ (call-next-method widget)
+ (realize-font! widget)
+ (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")
+ (call-next-method widget)
+ (thread-queue/queue-no-hang!
+ event-queue
+ (make-input-event
+ 'SET-WINDOW-SIZE
+ (lambda (widget)
+ (%trace "; input event: set-window-size "widget"\n")
+ (let ((geometry (fix-widget-geometry widget))
+ (screen (edwin-widget-screen widget))
+ (window (text-widget-buffer-frame widget)))
+ (let ((widget-x-size (width->x-size screen (fix-rect-width geometry)))
+ (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")
+ (if (not (and (fix:= widget-x-size window-x-size)
+ (fix:= widget-y-size window-y-size)))
+ (update-sizes screen)))))
+ widget)))
+
+(define (update-sizes screen)
+ ;; The underhanded way to adjust window sizes. This procedure does
+ ;; not use the :set-size! method, which presumably adjusts the
+ ;; widget sizes. It does the "opposite". It leaves the widgets
+ ;; alone and adjusts Edwin's window and screen sizes (using %
+ ;; operators).
+
+ (define (%set-size! screen window prefix)
+ (cond
+ ((buffer-frame? window)
+ (let ((widget (window-text-widget* window)))
+ (if widget
+ (let* ((view (fix-layout-view widget))
+ (width (fix-rect-width view))
+ (height (fix-rect-height view))
+ (x-size (width->x-size screen width))
+ (y-size (height->y-size screen height))
+ (x-size* (if (window-has-right-neighbor? window)
+ (fix:1+ x-size) x-size))
+ (y-size* (if (frame-modeline-inferior window)
+ (fix:1+ y-size) y-size))
+ (text (frame-text-inferior window)))
+
+ (%trace "; "prefix""text": "x-size"x"y-size" "view"\n")
+ (%set-window-x-size! text x-size)
+ (%set-window-y-size! text y-size)
+ (%trace "; "prefix""window": "x-size*"x"y-size*"\n")
+ (%set-window-x-size! window x-size*)
+ (%set-window-y-size! window y-size*))
+ (%trace "; "prefix""window": no widget\n"))))
+
+ ((or (combination? window)
+ (editor-frame? window))
+ (let ((total-x-size #f)
+ (total-y-size #f)
+ (vertical? (or (editor-frame? window)
+ (combination-vertical? window))))
+ (for-each
+ (lambda (inferior)
+ (let ((child (inferior-window inferior)))
+ (%set-size! screen child (string-append prefix "--"))
+ (if vertical?
+ (let ((x-size (%window-x-size child))
+ (y-size (%window-y-size child)))
+ (set! total-x-size
+ (if (not total-x-size)
+ x-size
+ (fix:max x-size total-x-size)))
+ (set! total-y-size
+ (if (not total-y-size)
+ y-size
+ (fix:+ total-y-size y-size))))
+ (let ((x-size (%window-x-size child))
+ (y-size (%window-y-size child)))
+ (set! total-y-size
+ (if (not total-y-size)
+ y-size
+ (fix:max y-size total-y-size)))
+ (set! total-x-size
+ (if (not total-x-size)
+ x-size
+ (fix:+ total-x-size x-size)))))))
+ (window-inferiors window))
+ (%trace "; "prefix""window": "total-x-size"x"total-y-size"\n")
+ (%set-window-x-size! window total-x-size)
+ (%set-window-y-size! window total-y-size)))
+
+ (else
+ (%trace "; "prefix""window": unexpected type\n"))))
+
+ (define (%set-starts! windows parent prefix x y)
+ (if (pair? windows)
+ (let* ((window (car windows))
+ (inferior (find-inferior (window-inferiors parent) window)))
+ (%trace "; "prefix""window" start: "x"x"y
+ " (was "
+ (inferior-x-start inferior)"x"(inferior-y-start inferior)
+ ")\n")
+ (%set-inferior-start! inferior x y)
+ (if (or (editor-frame? window)
+ (combination? window))
+ (%set-starts! (reverse! (%reversed-children window)) window
+ (string-append prefix "--")
+ x y))
+ (if (or (editor-frame? parent)
+ (and (combination? parent)
+ (combination-vertical? parent)))
+ (%set-starts! (cdr windows) parent prefix
+ x
+ (fix:+ y (%window-y-size window)))
+ (%set-starts! (cdr windows) parent prefix
+ (fix:+ x (%window-x-size window))
+ y)))))
+
+ (%trace "; update-sizes "screen"\n")
+ (let ((root (screen-root-window screen)))
+ (let ((x-size (%window-x-size root))
+ (y-size (%window-y-size root)))
+ (%trace "; initial root size: "x-size"x"y-size"\n"))
+ (%set-size! screen root "--")
+ (let ((x-size (%window-x-size root))
+ (y-size (%window-y-size root)))
+ (%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)))
+
+(define-integrable (editor-frame? object)
+ (object-of-class? editor-frame object))
+
+(define-class (<modeline-widget> (constructor make-modeline-widget (screen)))
+ (<edwin-widget>))
+
+(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)))
+ (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)
+ (set-fix-widget-focus-change-handler! widget focus-change-handler)
+ (set-fix-widget-visibility-notify-handler! widget visibility-notify-handler)
+ (set-fix-widget-key-press-handler! widget key-press-handler)
+ widget)
+
+(define-method fix-widget-realize-callback ((widget <modeline-widget>))
+ (%trace ";(fix-widget-realize-callback <modeline-widget>) "widget"\n")
+ (let ((geometry (fix-widget-geometry widget)))
+ (if (or (not (fix-rect-width geometry))
+ (not (fix-rect-height geometry)))
+ ;; Unfortunately a widget can be realized before it is
+ ;; allocated a size -- when it is added to a realized
+ ;; container. In this case, initialize WIDGET's size to
+ ;; something reasonable.
+ (let ((screen (edwin-widget-screen widget)))
+ (%trace "; uninitialized geometry: "geometry"\n")
+ (set-fix-rect-size! geometry -1 (y-size->height screen 1))
+ (%trace "; initialized geometry: "geometry"\n"))))
+ (call-next-method widget)
+ (realize-font! widget)
+ (set-gtk-widget-bg-color! widget "black"))
+
+(define-class (<buffer-frame-widget> (constructor ()))
- (call-next-method widget #f 0))
++ (<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.
+ )
+
+(define-method initialize-instance ((widget <buffer-frame-widget>))
+;;; (%trace ";(initialize-instance <buffer-frame-widget>) "widget"\n")
++ (call-next-method widget #f 0)
++ (gtk-orientable-set-orientation widget 'vertical))
+
+;; Assume there is one text-widget in a buffer-frame-widget.
+(define-integrable buffer-frame-widget-text* any-text-widget)
+\f
+;;; Incremental Redisplay
+
+;; Drawing a Buffer
+;;
+;; At its simplest, drawing a buffer is a process of searching for
+;; the "lines" between newlines and creating a <line-ink> for
+;; each. The <line-ink>s are sized -- layed out in a PangoLayout
+;; -- and arranged vertically against the left margin. Each line-ink
+;; remembers the start and end indices of a line in a buffer and the
+;; bounding box of the laid-up line/paragraph, and not much else.
+;;
+;; The INCREMENTAL version of this process UPDATES an existing column
+;; of <line-ink>s after the buffer has changed. It skips
+;; unchanged lines at the top, and re-lays out lines in the change
+;; region. Depending on the newlines in the region, it may re-use
+;; lines, create more, or erase some. Lines below the region are
+;; textually unchanged, and do not have to be re-layed out by Pango,
+;; though they may need to be moved to accommodate insertions and
+;; deletions above them.
+;;
+;; <line-ink>s are text-inks, but not simple-text-inks. The latter
+;; keep a PangoLayout around to service expose events. A drawing of a
+;; large buffer, with thousands of lines, if drawn with
+;; simple-text-inks, would allocate thousands of PangoLayouts, each
+;; with an image of a line (the images alone consuming more bytes than
+;; in the original buffer content).
+;;
+;; To lighten the footprint of a large buffer drawing, line-inks do
+;; not hold a PangoLayout, but create one on demand using the buffer
+;; text. They cache the created PangoLayout, and steal existing
+;; PangoLayouts from line-inks that are off-screen. The caching
+;; allows most expose events to find exposed line-inks ready with a
+;; PangoLayout to paint. As lines scroll into view, new PangoLayouts
+;; are allocated (or stolen), and the buffer text is re-imaged,
+;; styled, and re-layed-out just as when originally drawn. Sometimes,
+;; however, the original buffer text is NOT available.
+;;
+;; Expose events arrive ASYNCHRONOUSLY, and may find that a line's
+;; text has changed. The line may extend into (or just touch!) a
+;; buffer's change region. The original buffer text is no longer
+;; available, so the original PangoLayout cannot be re-constructed.
+;; The event handler must PUNT, and leave the line blank. (It will
+;; have been cleared to the background color.)
+;;
+;; To ensure that lines can be exposed as soon as they are re-drawn,
+;; each buffer drawing keeps an "update region" that it narrows as it
+;; redraws. The expose handlers refer to THIS change region, when
+;; available (during Redisplay), rather than the buffer's change
+;; region. Narrowing a buffer-drawing's update region BEFORE
+;; redrawing lines ensures that the resulting expose events will not
+;; be punted.
+;;
+;; Punted exposures should be infrequent, resulting from external
+;; events (e.g. an obscuring window was closed) exposing lines that
+;; have just recently changed in the buffer, during the tiny Eval and
+;; Redisplay parts of Edwin's main loop. These occasional misses
+;; should be hardly noticeable. The blank line should be quickly
+;; redrawn by the end of Redisplay.
+
+(define-method update-screen! ((screen <gtk-screen>) display-style)
+ (%trace "; (update-screen! <gtk-screen>) "screen" "display-style"\n")
+ (with-screen-in-update
+ screen
+ (lambda ()
+ (cond
+ ((display-style/no-screen-output? display-style)
+ (invalidate-all-drawings! screen)
+ (%trace "; (update-screen! <gtk-screen>) done: no-output\n")
+ 'NO-OUTPUT)
+ ((not (memq (screen-visibility screen) '(VISIBLE PARTIALLY-OBSCURED)))
+ (let ((visibility (screen-visibility screen)))
+ (if (not (eq? visibility 'DELETED))
+ (update-name screen))
+ (invalidate-all-drawings! screen)
+ (%trace "; (update-screen! <gtk-screen>) done: "visibility"\n")
+ visibility))
+ (else
+ (update-widgets screen)
+ (%trace "; update drawings\n")
+ (if (every (lambda (entry) (update-drawing screen (cdr entry)))
+ (gtk-screen-drawings screen))
+ (begin
+ (%trace "; update windows\n")
+ (for-each-text-widget screen update-window)
+ (if (display-style/discard-screen-contents? display-style)
+ (for-each-text-widget screen gtk-widget-queue-draw))
+ (update-blinking screen)
+ (%trace "; (update-screen! <gtk-screen>) done: finished\n")
+ #t)
+ (begin
+ (%trace "; (update-screen! <gtk-screen>) done: halted\n")
+ #f)))))))
+
+(define (invalidate-all-drawings! screen)
+ (%trace "; invalidated all drawings\n")
+ (for-each (lambda (entry)
+ (set-buffer-drawing-valid?! (cdr entry) #f))
+ (gtk-screen-drawings screen)))
+
+(define-integrable with-screen-in-update
+ (named-lambda (with-screen-in-update screen thunk)
+ (if (screen-in-update? screen)
+ (error "Recursive update:" screen))
+ (set-screen-in-update?! screen #t)
+ (let ((v (thunk)))
+ (set-screen-in-update?! screen #f)
+ ;; It would be better if this happened AFTER buffer change
+ ;; regions were cleared. Or use gdk-window-process-updates here?
+ (for-each (lambda (buffer.drawing)
+ (set-buffer-drawing-update-region! (cdr buffer.drawing) #f))
+ (gtk-screen-drawings screen))
+ v)))
+
+(define (update-blinking screen)
+ ;; Sometimes called by a callback (i.e. without-interrupts). Frobs
+ ;; JUST the canvas (else must queue an editor input event.)
+ (%trace "; update blinking "screen"\n")
+ (if (not (gtk-screen-in-focus? screen))
+ (begin
+ (%trace "; not the focus\n")
+ (blink! screen #f))
+ (let ((window (screen-cursor-window screen)))
+ (if (not window)
+ (begin
+ (%trace "; no cursor window\n")
+ (blink! screen #f))
+ (let ((widget (window-text-widget* window)))
+ (%trace "; cursor window: "window" "widget"\n")
+ (guarantee-text-widget widget 'update-blinking)
+ (let ((cursor (text-widget-cursor-ink widget)))
+ (if (not cursor)
+ (begin
+ (%trace "; no cursor yet\n")
+ (blink! screen #f))
+ (begin
+ (%trace "; enabling "cursor"\n")
+ (visible! cursor #t)
+ (blink! screen cursor)))))))))
+
+(define-method update-screen-window!
+ ((screen <gtk-screen>) window display-style)
+ (%trace "; (update-screen-window! <gtk-screen>) "screen" "window"\n")
+ (let ((v (update-screens! display-style)))
+ (%trace "; (update-screen-window! <gtk-screen>) "screen" "window" => "v"\n")
+ v))
+
+(define (update-widget-buffer widget)
+ (%trace "; update-widget-buffer "widget"\n")
+ (let ((screen (edwin-widget-screen widget))
+ (window (text-widget-buffer-frame widget)))
+
+ (define-integrable (main)
+ (let* ((new-buffer (window-buffer window))
+ (old-drawing (text-widget-buffer-drawing widget))
+ (old-buffer (and old-drawing
+ (buffer-drawing-buffer old-drawing))))
+ (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)
+ (text-widget-override-drawing widget)))
+ (set-fix-layout-drawing! widget new-drawing 0 0))))))
+
+ (define (re-cursor widget drawing)
+ ;; Re-set text-WIDGET-cursor-ink per new buffer in DRAWING.
+ (%trace ";\tre-cursor "widget" "drawing"\n")
+ (let ((cursor (text-widget-cursor-ink widget))
+ (modeline (text-widget-modeline widget)))
+ (cond ((not cursor)
+ (let ((new (make-cursor-ink))
+ (width (fix:quotient (gtk-screen-char-width screen) 2))
+ (height (gtk-screen-line-height screen))
+ (space (gtk-screen-line-spacing screen))
+ (widgets (list widget)))
+ (%trace ";\t new "new" for new "widget"\n")
+ (set-box-ink! new 0 space width height)
+ (set-cursor-ink-widget-list! new widgets)
+ (if (not modeline)
+ (begin
+ (set-fix-ink-widgets! new '())
+ (set-cursor-ink-visible?! new #f))
+ (begin
+ (set-fix-ink-widgets! new widgets)))
+ (set-text-widget-cursor-ink! widget new)
+ (fix-drawing-add-ink! drawing new 'bottom)))
+ ((not (eq? drawing (fix-ink-drawing cursor)))
+ (%trace ";\t moving "cursor" to new "drawing"\n")
+ (fix-ink-remove! cursor)
+ (set-box-ink-position! cursor 0 (gtk-screen-line-spacing screen))
+ (fix-drawing-add-ink! drawing cursor 'bottom))
+ (else
+ (%trace ";\t no change\n")))))
+
+ (define (find/create-drawing widget)
+ (%trace ";\tfind/create-drawing for "widget" ("window")\n")
+ (let ((buffer (window-buffer window))
+ (drawings (gtk-screen-drawings screen)))
+ (or
+ (cdr* (find (lambda (buffer.drawing)
+ (and (eq? (car buffer.drawing) buffer)
+ (drawing-match? (cdr buffer.drawing))))
+ drawings))
+ (let* ((bufwin (frame-text-inferior window))
+ (new (make-buffer-drawing
+ buffer
+ (%window-tab-width bufwin)
+ (%window-char-image-strings bufwin))))
+ (%trace ";\t new buffer drawing: "new" "buffer
+ " "window" "widget"\n")
+ (set-gtk-screen-drawings! screen (cons (cons buffer new) drawings))
+ new))))
+
+ (define (drawing-match? drawing)
+ ;; #t iff nothing has changed, in terms of drawing style
+ ;; parameters, between WINDOW and DRAWING.
+ (let ((bufwin (frame-text-inferior window)))
+ (and (fix:= (%window-tab-width bufwin)
+ (buffer-drawing-tab-width drawing))
+ (eq? (%window-char-image-strings bufwin)
+ (buffer-drawing-char-image-strings drawing)))))
+
+ (main)))
+
+(define (update-window widget)
+ (%trace "; update-window "widget"\n")
+ (let ((window (text-widget-buffer-frame widget)))
+ (let ((message (window-override-message window))
+ (drawing (fix-layout-drawing widget)) ; current drawing: either...
+ (override (text-widget-override-drawing widget)) ; this...
+ (text (text-widget-buffer-drawing widget))) ; or this.
+ (guarantee-fix-drawing drawing 'update-window)
+ (guarantee-fix-drawing override 'update-window)
+ (guarantee-fix-drawing text 'update-window)
+ (if message
+ (begin
+ ;; ReDisplay message in override.
+ (let* ((text-ink (car (fix-drawing-display-list override))))
+ (set-simple-text-ink-text! text-ink widget message)
+ (let ((e (fix-ink-extent text-ink)))
+ (set-fix-drawing-size! override
+ (fix-rect-width e)
+ (fix-rect-height e))))
+ (if (not (eq? override drawing))
+ (let ((saved-pos (text-widget-text-pos widget))
+ (view (fix-layout-view widget)))
+ (set-car! saved-pos (fix-rect-x view))
+ (set-cdr! saved-pos (fix-rect-y view))
+ (%trace ";\tsaving text position "saved-pos"\n")
+ (set-fix-layout-drawing! widget override 0 0))
+ (%trace ";\toverride still up\n")))
+ (begin
+ ;; ReDisplay text, and scroll to cursor.
+ (if (not (eq? text drawing))
+ (let ((saved-pos (text-widget-text-pos widget)))
+ (%trace ";\trestoring "text" to "saved-pos"\n")
+ (set-fix-layout-drawing! widget text
+ (car saved-pos) (cdr saved-pos)))
+ (%trace ";\ttext still up\n"))
+ (update-cursor widget)
+ (let ((extent (fix-ink-extent (text-widget-cursor-ink widget))))
+ (%trace ";\tscrolling to "extent"\n")
+ (fix-layout-scroll-nw! widget extent)
+ (%trace ";\tview: "(fix-layout-view widget)"\n"))
+ (update-modeline widget))))))
+
+;; This variable caches a modeline image buffer. A modeline update
+;; hacks this buffer, then compares it to the string in the simple-
+;; text-ink. This avoids much consing and widget damage. The Edwin
+;; thread should be the only thread accessing this resource.
+(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
+ ;; whatnot, off the right side of the widget.
+ (x-size (+ 5 (%window-x-size window))))
+ (if widget
+ (let ((modeline (text-widget-modeline widget)))
+ (if modeline
+ (begin
+ (let ((maxlen (string-maximum-length modeline-image)))
+ (if (> x-size maxlen)
+ (set! modeline-image (string-allocate x-size))
+ (set-string-length! modeline-image maxlen)))
+ (modeline-string! window modeline-image 0 x-size)
+ (set-string-length! modeline-image x-size)
+ (let* ((drawing (fix-layout-drawing modeline))
+ (inks (fix-drawing-display-list drawing))
+ (ink (cond ((null? inks)
+ (let ((i (make-simple-text-ink)))
+ (fix-drawing-add-ink! drawing i)
+ i))
+ ((simple-text-ink? (car inks)) (car inks))
+ (else (error "bogus modeline drawing"))))
+ (old (simple-text-ink-text ink)))
+ (if (not (and old (string=? old modeline-image)))
+ (let ((copy (string-copy modeline-image)))
+ (set-simple-text-ink-text! ink widget copy)
+ ;; Ensure that text-ink is wider than widget???
+ (%trace ";\tupdated "modeline": \""copy"\"\n"))
+ (%trace ";\tunchanged "modeline"\n"))))
+ (%trace ";\tno modeline\n")))
+ (%trace ";\tno widget!\n")))
+ (%trace "; update-modeline done\n"))
+
+(define (update-name screen)
+ (let ((name (frame-name screen))
+ (name* (gtk-screen-name screen)))
+ (if (and name (or (not name*) (not (string=? name name*))))
+ (begin
+ (set-gtk-screen-name! screen name)
+ (gtk-window-set-title (gtk-screen-toplevel screen) name)))))
+
+(define (frame-name screen)
+ (let* ((window
+ (if (and (eq? screen (selected-screen)) (within-typein-edit?))
+ (typein-edit-other-window)
+ (screen-selected-window screen)))
+ (buffer (window-buffer window))
+ (format (ref-variable frame-name-format buffer)))
+ (and format
+ (string-trim-right
+ (format-modeline-string
+ window format (ref-variable frame-name-length buffer))))))
+\f
+(define (update-drawing screen drawing)
+ ;; Redraw a buffer-DRAWING.
+ (%trace "; update-drawing "screen" "drawing"\n")
+
+ ;; This is the traditional Emacs layout, in a fixed-width font, with
+ ;; 2 and 4 character depictions of many characters (e.g. ^@ and
+ ;; \200).
+
+ ;; Line wrapping is not currently supported.
+
+ ;; Consider first a diagram of our buffer:
+ ;;
+ ;; unchanged prefix
+ ;; change-region
+ ;; unchanged suffix
+ ;;
+ ;; and the process of redrawing it:
+ ;;
+ ;; Skip through prefix, to a line needing updating -- a line
+ ;; stretching into the change region. There may be no such line
+ ;; if there is no next line, or the next line does not need
+ ;; updating -- lies beyond the change region.
+ ;;
+ ;; Steal this line-needing-updating (if any); lay it out again;
+ ;; move/re-size it. Steal it AND the next... until the last
+ ;; stolen line reaches beyond the change region, or there are no
+ ;; more lines-needing-updating to steal. Remove any remaining
+ ;; lines-needing-updating. If the last stolen line did NOT
+ ;; reach beyond the change region (nor hit the buffer's end),
+ ;; add lines until the last added line does. The last stolen or
+ ;; added line should MEET the next line, a line NOT needing
+ ;; updating (if any, else the buffer's end).
+ ;;
+ ;; Move the remaining lines -- those entirely in the suffix (if
+ ;; any). Note that if the first remaining line does not need to
+ ;; move, neither do the rest.
+ ;;
+ ;; Now consider display-start/end:
+ ;;
+ ;; Remove lines starting before display-start.
+ ;; Steal/add lines until they match the prefix (or perhaps the
+ ;; suffix, OR the display-end).
+ ;;
+ ;; As before, skip through the prefix, except that these
+ ;; "unchanged" lines might have to move.
+ ;;
+ ;; As before, steal/add changed lines until they reach (and
+ ;; meet!) lines in the suffix.
+ ;;
+ ;; As before, move lines in the suffix as necessary, except do
+ ;; not bother with lines reaching beyond display-end.
+ ;;
+ ;; Remove lines extending beyond display-end. Add lines until
+ ;; they hit display-end.
+
+ (let* ((line-height (gtk-screen-line-height screen))
+ (line-spacing (gtk-screen-line-spacing screen))
+ (drawing-extent #f) ;set when an ink extent is known
+ (pango-layout #f) ;set when a pango-layout is allocated
+ (buffer (buffer-drawing-buffer drawing))
+ (group (buffer-group buffer))
+ (display-start (group-display-start group))
+ (display-end (group-display-end group))
+ (change-start-index (if (buffer-drawing-valid? drawing)
+ (group-start-changes-index group)
+ (mark-index display-start)))
+ (change-end-index (if (buffer-drawing-valid? drawing)
+ (group-end-changes-index group)
+ (mark-index display-end)))
+ (update-region #f))
+
+ (define-syntax %trace3
+ (syntax-rules ()
+ ((_ ARGS ...) (if %trace-redraw?
+ (apply outf-error (%trace-simplify ARGS ...))))))
+
+ (define-integrable (main)
+ (%trace3 ";\tdrawing/buffer ticks:"
+ " "(buffer-drawing-modified-tick drawing)
+ "/"(group-modified-tick group)"\n"
+ ";\tchange/display regions:"
+ " "change-start-index"-"change-end-index
+ "/"display-start"-"display-end"\n")
+ (init-start/end)
+ (cond
+ ((no-display-changes?)
+ (%trace ";\tno changes\n")
+ #t)
+ (else
+ (set! update-region (cons change-start-index change-end-index))
+ (set-buffer-drawing-update-region! drawing update-region)
+ (let ((finished?
+
+ (redraw-start
+ (next-lines (fix-drawing-display-list drawing))
+ display-start 1 line-spacing
+ (lambda (lines start num y)
+
+ (redraw-prefix
+ lines start num y
+ (lambda (lines start num y)
+
+ (redraw-changed
+ lines start num y
+ (lambda (lines start num y)
+
+ (redraw-suffix
+ lines start num y
+
+ redraw-end)))))))))
+
+ (set-buffer-drawing-update-region! drawing finished?)
+ (if finished?
+ (begin
+ (set-size)
+ (move-mark-to! (buffer-drawing-display-start drawing)
+ display-start)
+ (move-mark-to! (buffer-drawing-display-end drawing)
+ display-end)
+ (set-buffer-drawing-modified-tick!
+ drawing (group-modified-tick group))
+ (set-buffer-drawing-valid?! drawing #t)))
+
+ (if pango-layout (gobject-unref! pango-layout))
+ finished?))))
+
+ (define-integrable (init-start/end)
+ (if (not (buffer-drawing-display-start drawing))
+ (begin
+ (set-buffer-drawing-display-start! drawing
+ (mark-permanent-copy
+ display-start))
+ (set-buffer-drawing-display-end! drawing
+ (mark-permanent-copy
+ display-end)))))
+ (define-integrable (set-size)
+ (if drawing-extent
+ (let ((width+
+ (fix:+ (fix-rect-max-x drawing-extent)
+ (gtk-screen-char-width screen)))
+ (height+
+ (fix:+ (fix-rect-max-y drawing-extent)
+ (if (final-newline? group)
+ (fix:+ line-spacing
+ (fix:+ line-height
+ line-spacing))
+ line-spacing))))
+ (fix-rect-union! drawing-extent (make-fix-rect 0 0 width+ height+))
+ (if (not (and (fix:= (fix-rect-min-x drawing-extent) 0)
+ (fix:= (fix-rect-min-y drawing-extent) 0)))
+ (%trace "; Warning: drawing min x,y"
+ " = "(fix-rect-min-x drawing-extent)
+ ","(fix-rect-min-y drawing-extent)"!\n"))
+ (set-fix-drawing-size! drawing
+ (fix-rect-max-x drawing-extent)
+ (fix-rect-max-y drawing-extent)))
+ (set-fix-drawing-size! drawing 0 0))
+ (%trace ";\tnew drawing extent: "(fix-drawing-extent drawing)"\n"))
+
+ (define (redraw-start lines start num y receiver)
+ (%trace3 "; redraw-start "lines" "start" "num" "y"\n")
+ (let ((old-start (and (more-lines? lines)
+ (%unchanged? (car lines)
+ change-start-index change-end-index)
+ (line-ink-start (car lines)))))
+ (cond ((not old-start)
+ (%trace3 "; hit changed "(and(not(null? lines))(car lines))"\n")
+ (receiver lines start num y))
+ ((mark= start old-start)
+ (%trace3 "; matched "(car lines)"\n")
+ (receiver lines start num y))
+ ((mark< start old-start)
+ (let ((new (add-line start num y lines)))
+ (%trace3 "; added "new"\n")
+ (redraw-start lines (next-start new)
+ (next-num num) (next-y new) receiver)))
+ ((mark< old-start start) ;uncommon
+ (redraw-start (remove-lines-before lines start)
+ start num y receiver))
+ (else (%trace3 "; Unreachable?!\n")))))
+
+ (define (redraw-prefix lines start num y receiver)
+ (%trace3 "; redraw-prefix "lines" "start" "num" "y"\n")
+ (cond (((editor-halt-update? current-editor))
+ (%trace3 "; halt redraw!\n")
+ #f)
+ ((not (more-lines? lines))
+ (%trace3 "; no more lines\n")
+ (receiver lines start num y))
+ ((and (%unchanged? (car lines) change-start-index change-end-index)
+ (mark<= (line-ink-end (car lines)) display-end))
+ (let ((next-y (move-line! (car lines) start num y)))
+ (%trace3 "; prefix "(car lines)"\n")
+ (redraw-prefix (next-lines (cdr lines))
+ (next-start (car lines))
+ (next-num num)
+ next-y
+ receiver)))
+ (else
+ (%trace3 "; not prefix "(car lines)"\n")
+ (receiver lines start num y))))
+
+ (define (redraw-changed lines start num y receiver)
+ (%trace3 "; redraw-changed "lines" "start" "num" "y"\n")
+ (if (not change-start-index)
+ (begin
+ (%trace3 "; no change region\n")
+ (receiver lines start num y))
+ (steal-changed
+ lines start num y
+ (lambda (lines start num y)
+ (remove-changed
+ lines start num y
+ (lambda (lines start num y)
+ (add-changed
+ lines start num y
+ (lambda (lines start num y)
+ (receiver lines start num y)))))))))
+
+ (define (steal-changed lines start num y receiver)
+ (%trace3 "; steal-changed "lines" "start" "num" "y"\n")
+ (cond (((editor-halt-update? current-editor))
+ (%trace3 "; halt redraw!\n")
+ #f)
+ ((not (more-lines? lines))
+ (%trace3 "; no more lines\n")
+ (receiver lines start num y))
+ ((mark<= display-end start)
+ (%trace3 "; hit end at "start" with "lines"\n")
+ (receiver lines start num y))
+ ((%unchanged? (car lines) change-start-index change-end-index)
+ (%trace3 "; unchanged "(car lines)"\n")
+ (receiver lines start num y))
+ ((fix:< change-start-index (mark-index start))
+ (%trace3 "; beyond changes at "start"\n")
+ (receiver lines start num y))
+ (else
+ (steal-line! (car lines) start num y)
+ (%trace3 "; stole line "(car lines)"\n")
+ (let* ((line (car lines))
+ (next-start (next-start line))
+ (next-lines (next-lines (cdr lines))))
+ (steal-changed (remove-lines-before next-lines next-start)
+ next-start (next-num num) (next-y line)
+ receiver)))))
+
+ (define (remove-changed lines start num y receiver)
+ (%trace3 "; remove-changed "lines" "start" "num" "y"\n")
+ (cond (((editor-halt-update? current-editor))
+ (%trace3 "; halt redraw!\n")
+ #f)
+ ((not (more-lines? lines))
+ (%trace3 "; no more lines\n")
+ (receiver lines start num y))
+ ((%unchanged? (car lines) change-start-index change-end-index)
+ (%trace3 "; unchanged "(car lines)"\n")
+ (receiver lines start num y))
+ (else
+ (remove-line (car lines))
+ (remove-changed (next-lines (cdr lines))
+ start num y receiver))))
+
+ (define (add-changed lines start num y receiver)
+ (%trace3 "; add-changed "lines" "start" "num" "y"\n")
+ (cond (((editor-halt-update? current-editor))
+ (%trace3 "; halt redraw!\n")
+ #f)
+ ((mark<= display-end start)
+ (%trace3 "; hit end at "start" with "lines"\n")
+ (receiver lines start num y))
+ ((fix:<= (mark-index start) change-end-index)
+ (let* ((new (add-line start num y lines))
+ (new-start (next-start new)))
+ (%trace3 "; added "new"\n")
+ (add-changed (remove-lines-before lines new-start)
+ new-start (next-num num) (next-y new) receiver)))
+ (else
+ (%trace3 "; beyond change at "start"\n")
+ (receiver lines start num y))))
+
+ (define (redraw-suffix lines start num y receiver)
+ (%trace3 "; redraw-suffix "lines" "start" "num" "y"\n")
+ (cond (((editor-halt-update? current-editor))
+ (%trace3 "; halt redraw!\n")
+ #f)
+ ((not (more-lines? lines))
+ (%trace3 "; no more lines\n")
+ (receiver lines start num y))
+ ((mark= display-end start)
+ (%trace3 "; at end "(car lines)"\n")
+ (receiver lines start num y))
+ ((mark< display-end start)
+ (%trace3 "; beyond end "(car lines)"\n")
+ (receiver lines start num y))
+ (else
+ (let ((next-y (move-line! (car lines) start num y)))
+ (%trace3 "; suffix "(car lines)"\n")
+ (redraw-suffix (next-lines (cdr lines))
+ (next-start (car lines))
+ (next-num num)
+ next-y
+ receiver)))))
+
+ (define (redraw-end lines start num y)
+ (%trace3 "; redraw-end "lines" "start" "num" "y"\n")
+ (cond (((editor-halt-update? current-editor))
+ (%trace3 "; halt redraw!\n")
+ #f)
+ ((mark= start display-end) ;common
+ (%trace3 "; clipping "lines"\n")
+ (remove-lines lines)
+ #t)
+ ((and (mark< start display-end)
+ (more-lines? lines))
+ (steal-line! (car lines) start num y)
+ (%trace3 "; stole line "(car lines)"\n")
+ (redraw-end (next-lines (cdr lines))
+ (next-start (car lines))
+ (next-num num)
+ (next-y (car lines))))
+ ((mark< start display-end) ;no more lines to steal
+ (let ((new (add-line start num y '())))
+ (%trace3 "; added "new"\n")
+ (redraw-end lines
+ (next-start new)
+ (next-num num)
+ (next-y new))))
+ (else
+ ;; (mark< display-end start)
+ (%trace3 "; Warning: last line (before "(car lines)")"
+ " ended beyond display-end!\n")
+ (remove-lines lines))))
+\f
+ ;; If all inks in the drawing go through next-lines,
+ ;; move-line!, add-line or steal-line!, then all of their extents
+ ;; can be unioned to get the extent encompassing them all.
+ (define (union-ink! ink)
+ (union-extent! (fix-ink-extent ink)))
+
+ (define (union-extent! extent)
+ (if (not drawing-extent)
+ (set! drawing-extent (copy-fix-rect extent))
+ (fix-rect-union! drawing-extent extent)))
+
+ ;; If the update region is narrowed to exclude each line before it
+ ;; is re-drawn, then the resulting exposes will not be punted by
+ ;; the line-ink expose handler (which is otherwise shuns change
+ ;; regions). The expose event could arrive instantly (thread
+ ;; timer interrupts permitting), so this must be done before
+ ;; (re)drawing the line-ink.
+ (define (update-region! start)
+ (set-car! update-region (mark-index start)))
+
+ ;; Keeps the next line to redraw on the front, skipping inks like
+ ;; cursors, selection boxes, embedded images/widgets/whatnot.
+ (define (next-lines inks)
+ (cond ((null? inks) '())
+ ((line-ink? (car inks)) inks)
+ ((cursor-ink? (car inks))
+ ;; Punt cursor extents. They often move around at the last
+ ;; moment. :-)
+ (next-lines (cdr inks)))
+ ((fix-ink? (car inks))
+ (union-ink! (car inks))
+ (next-lines (cdr inks)))
+ (else
+ (%trace3 "; Warning: bogus "(car inks)" in "drawing"\n")
+ (next-lines (cdr inks)))))
+
+ (define-integrable next-start line-ink-end)
+
+ (define-integrable next-num fix:1+)
+
+ (define (next-y line)
+ (next-y-extent (fix-ink-extent line)))
+
+ (define (next-y-extent extent)
+ (fix:+ (fix-rect-max-y extent) line-spacing))
+
+ (define (more-lines? inks)
+ (and (not (null? inks))
+ (line-ink? (car inks))))
+
+ (define (remove-lines-before lines start)
+ ;; Used to clear off (erase!) lines that have been run over by
+ ;; newly added (stolen) lines.
+ (%trace3 "; remove-lines-before "start" "lines"\n")
+ (cond ((null? lines) '())
+ ((mark< (line-ink-start (car lines)) start)
+ (remove-line (car lines))
+ (remove-lines-before (next-lines (cdr lines)) start))
+ (else lines)))
+
+ (define (remove-lines lines)
+ ;; Used to clear off lines that hang on after the end.
+ (%trace3 "; remove-lines "lines"\n")
+ (cond ((null? lines) '())
+ (else
+ (remove-line (car lines))
+ (remove-lines (next-lines (cdr lines))))))
+
+ (define (add-line start num y old)
+ (%trace3 "; add-line "start" "num" "y" "old"\n")
+ (let ((new (make-line-ink)))
+ (set-line-ink-start! new (mark-permanent-copy start))
+ (update-region! start)
+ (set-line-ink-end! new (mark-permanent-copy start))
+ (set-line-ink-number! new num)
+ (fix-drawing-add-ink! drawing new (and (pair? old) (car old)))
+ (redraw-line! new 0 y (layout)) ;Needs the ink on its drawing.
+ (union-ink! new)
+ new))
+
+ (define (steal-line! line start num y)
+ (%trace3 "; steal-line! "line" "start" "num" "y"\n")
+ (move-mark-to! (line-ink-start line) start)
+ (update-region! start)
+ (set-line-ink-number! line num)
+ (redraw-line! line 0 y (layout))
+ (union-ink! line))
+
+ (define (move-line! line start num y)
+ (let* ((extent (fix-ink-extent line))
+ (old-num (line-ink-number line))
+ (old-y (fix-rect-y extent)))
+ (update-region! start)
+ (if (not (fix:= old-y y))
+ (set-text-ink-position! line 0 y))
+ (if (not (fix:= old-num num))
+ (set-line-ink-number! line num))
+ (if (not (mark= start (line-ink-start line)))
+ (warn "mismatched line-ink start:" start line))
+ (union-ink! line)
+ (next-y-extent extent)))
+
+ (define (remove-line line)
+ (mark-temporary! (line-ink-start line))
+ (mark-temporary! (line-ink-end line))
+ (without-interrupts
+ (lambda ()
+ (clear-cached-pango-layout line)
+ (fix-ink-remove! line))))
+
+ (define (no-display-changes?)
+ ;; If the drawing already agrees with the buffer and its current
+ ;; clipping, return #t.
+ (let ((old-tick (buffer-drawing-modified-tick drawing)))
+ (and (fix:= old-tick (group-modified-tick group)) ;already redrawn
+ (let ((old-start (buffer-drawing-display-start drawing))
+ (old-end (buffer-drawing-display-end drawing)))
+ (and (mark= old-start display-start)
+ (mark= old-end display-end))))))
+
+ (define (layout)
+ (if pango-layout pango-layout
+ (let ((new (gtk-widget-create-pango-layout
+ (gtk-screen-toplevel screen))))
+ (%trace3 "; created "new" to lay up new text\n")
+ (set! pango-layout new)
+ new)))
+
+ (main)))
+
+(define %trace-redraw? #f)
+
+(define (%trace-simplify . args)
+ (map (lambda (obj)
+ (cond ((mark? obj) (mark-index obj))
+ ((and (pair? obj) (line-ink? (car obj)))
+ (list (car obj) '...))
+ (else obj)))
+ args))
+
+(define (redraw-line! line x y pango-layout)
+ ;; Updates LINE by (re)parsing its buffer. (Re)Images and
+ ;; (re)lays-out the line to get its dimensions. (Re)sizes LINE and
+ ;; (re)positions it at (X, Y). A separate PANGO-LAYOUT is (re)used
+ ;; during this process, and any cached layout is cleared.
+
+ (define-syntax %trace3
+ (syntax-rules ()
+ ((_ ARGS ...) (if %trace-redraw?
+ (apply outf-error (%trace-simplify ARGS ...))))))
+
+ (%trace3 ";\t redraw-line! "line" from "(line-ink-start line)
+ " ("x","y") with "pango-layout"\n")
+ (layout-line! line pango-layout)
+ (pango-layout-get-pixel-extents
+ pango-layout
+ (lambda (width height)
+ (without-interrupts
+ (lambda ()
+ (clear-cached-pango-layout line)
+ (%trace3 ";\t erasing "(fix-ink-extent line)"\n")
+ (drawing-damage line)
+ (let ((extent (fix-ink-extent line)))
+ (set-fix-rect-size! extent width height)
+ (set-fix-rect-position! extent x y))
+ (%trace3 ";\t drawing "(fix-ink-extent line)"\n")
+ (drawing-damage line))))))
+
+(define image-buffer-size (* 50 1024))
+(define image-buffer (string-allocate image-buffer-size))
+(define-integrable image-results substring-image-results)
+
+(define (layout-line! line pango-layout)
+ (let* ((drawing (fix-ink-drawing line))
+ (buffer (buffer-drawing-buffer drawing))
+ (group (buffer-group buffer))
+ (max-image-size (fix:-1+ image-buffer-size)))
+ ;; Image the whole paragraph into a max-sized image-buffer.
+ (set-string-length! image-buffer image-buffer-size)
+ (group-line-image!
+ group (line-ink-start-index line) (group-display-end-index group)
+ image-buffer 0 max-image-size
+ (buffer-drawing-tab-width drawing)
+ 0 ;; column-offset
+ (buffer-drawing-char-image-strings drawing)
+ (lambda (text-index image-index)
+ (if (fix:= image-index max-image-size)
+ (warn ";layout-line!: long paragraph"))
+ (set-mark-index! (line-ink-end line) text-index)
+
+ ;; Run Pango on buffer.
+ (set-string-length! image-buffer image-index)
+ (pango-layout-set-text pango-layout image-buffer)))))
+
+(define (final-newline? group)
+ (let ((index (group-display-end-index group)))
+ (and (not (group-start-index? group index))
+ (char=? #\newline (group-left-char group index)))))
+
+(define-integrable unchanged?
+ (named-lambda (unchanged? line)
+ (let* ((drawing (fix-ink-drawing line))
+ (update-region (buffer-drawing-update-region drawing)))
+ (cond ((eq? update-region #t) #t)
+ ((pair? update-region)
+ (or
+ (let ((change-start (car update-region))
+ (line-end (line-ink-end-index line)))
+ (fix:<= line-end change-start))
+ (let ((change-end (cdr update-region))
+ (line-start (line-ink-start-index line)))
+ (fix:< change-end line-start))))
+ (else
+ (let ((buffer (buffer-drawing-buffer drawing)))
+ (and buffer
+ (let ((group (buffer-group buffer)))
+ (%unchanged? line
+ (group-start-changes-index group)
+ (group-end-changes-index group))))))))))
+
+(define-integrable %unchanged?
+ (named-lambda (%unchanged? line change-start change-end)
+ (or
+ ;; Common trivial case: no change = unchanged.
+ (not change-start)
+
+ ;; First case: the change region ends before LINE starts.
+ ;;
+ ;; LINE and change region may not touch. The change region may
+ ;; have removed the newline before LINE, or inserted new text
+ ;; after the newline, changing LINE's start.
+ (let ((line-start (line-ink-start-index line)))
+ (fix:< change-end line-start))
+
+ ;; Second case: the change region starts after LINE ends.
+ ;;
+ ;; LINE must end with a newline, else a change region touching
+ ;; the end is adding to the line. Rather than test for this,
+ ;; consider touching lines as NOT unchanged.
+ (let ((line-end (line-ink-end-index line)))
+ (fix:< line-end change-start)))))
+\f
+(define (update-cursor widget)
+ (%trace ";\t update-cursor "widget"\n")
+ (let ((window (text-widget-buffer-frame widget))
+ (cursor (text-widget-cursor-ink widget)))
+ (%trace ";\t cursor: "cursor"\n")
+ (redraw-cursor widget (window-point window))
+
+ ;; Get cursor appearance right per current mode. An active
+ ;; 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)
+ (visible! cursor #t))
+ ((and (text-widget? widget)
+ (not (text-widget-modeline widget)))
+ (visible! cursor #f))
+ (else ;; text widget
+ (visible! cursor #t))))))
+
+(define (redraw-cursor widget point)
+ (%trace ";\t redraw-cursor at "point" in "widget"\n")
+ (let* ((window (text-widget-buffer-frame widget))
+ (screen (window-screen window))
+ (cursor (text-widget-cursor-ink widget))
+ (line (find-line-at point widget))
+ (group (mark-group point)))
+ (%trace ";\t\tfound line: "line"\n")
+
+ (define-integrable (main)
+ (cond
+ ((not cursor)
+ (%trace ";\t\tno widget for "window"\n")
+ #t)
+
+ ;; When beyond a final newline, position cursor where next line
+ ;; would start.
+ ((and line
+ (mark= point (group-display-end group))
+ (final-newline? group))
+ (let* ((extent (fix-ink-extent line))
+ (line-spacing (gtk-screen-line-spacing screen))
+ (y (fix:+ (fix-rect-max-y extent) line-spacing)))
+ (%trace ";\t\tredraw-cursor beyond final newline, at 0,"y"\n")
+ (set-half-box! 0 y)))
+
+ ;; Else at end (or inside) found line.
+ (line
+ (let* ((extent (fix-ink-extent line))
+ (layout (text-ink-pango-layout line))
+ (column (image-column point line)))
+ (pango-layout-index-to-pos
+ layout column
+ (lambda (xG yG widthG heightG)
+ (let ((log-x (fix:+ xG (fix-rect-x extent)))
+ (log-y (fix:+ yG (fix-rect-y extent))))
+ (%trace ";\t\tredraw-cursor: index-to-pos: "column
+ " => "log-x","log-y" "widthG"x"heightG" - "layout"\n")
+ (set-box! log-x log-y widthG heightG))))))
+
+ ;; Else... a half-char box for the empty buffer.
+ (else
+ (%trace ";\t\tno line found: half box at 0,0\n")
+ (set-half-box! 0 0))))
+
+ (define (set-half-box! x y)
+ (let ((half-width (quotient (gtk-screen-char-width screen) 2))
+ (line-height (gtk-screen-line-height screen)))
+ (set-box-ink! cursor x y half-width line-height))
+ #t)
+
+ (define (set-box! x y width height)
+ (if (fix:< width 5)
+ (set-box-ink! cursor x y 5 height)
+ (set-box-ink! cursor x y width height))
+ #t)
+
+ (main)))
+
+(define (image-column point line)
+ ;; Returns the index of the character at POINT within LINE's image.
+ (let* ((drawing (fix-ink-drawing line))
+ (buffer (buffer-drawing-buffer drawing))
+ (group (buffer-group buffer)))
+ (group-columns group
+ (mark-index (line-ink-start line))
+ (mark-index point)
+ 0 ;; start column
+ (buffer-drawing-tab-width drawing)
+ (buffer-drawing-char-image-strings drawing))))
+\f
+;;; Buffer Drawings and Buffer Lines
+
+(define-class (<buffer-drawing>
+ (constructor make-buffer-drawing
+ (buffer tab-width char-image-strings)
+ no-init))
+ (<fix-drawing>)
+
+ ;; The buffer being drawn, and the "visual" parameters affecting its
+ ;; rendition.
+ (buffer define accessor)
+ (tab-width define accessor)
+ (char-image-strings define accessor)
+
+ ;; If the drawing has not been kept up-to-date with the buffer, set
+ ;; this flag to #f. The next redraw will ignore the buffer's change
+ ;; region and redraw the entire buffer (and set this back to #t).
+ (valid? define standard initial-value #f)
+
+ ;; The buffer's modified-tick, and copies of the buffer's
+ ;; display-start/end at the time of the last successful redraw.
+ (modified-tick define standard initial-value #f)
+ (display-start define standard initial-value #f)
+ (display-end define standard initial-value #f)
+
+ ;; During redisplay this is the portion of the buffer's change
+ ;; region that has yet to be re-drawn.
+ (update-region define standard initial-value #f)
+
+ ;; These are the particulars of the set of PangoLayouts in use.
+ ;; Each element is a "cache" containing: (<line-ink>|#f
+ ;; . <pango-layout>). Thus each layout is either idle, or in use --
+ ;; in a line-ink's cached-pango-layout slot.
+ (pango-layout-caches define standard initial-value '()))
+
+;; The pango-layout-cache abstraction:
+(define-integrable make-cache cons)
+(define-integrable cache-line car)
+(define-integrable cache-layout cdr)
+(define-integrable set-cache-line! set-car!)
+(define (find-cache line drawing)
+ (or
+ (assq line (buffer-drawing-pango-layout-caches drawing))
+ (error "missing from pango-layout cache" line drawing)))
+
+(define-class (<line-ink> (constructor ()))
+ (<text-ink>)
+
+ (start define standard initial-value #f)
+ (end define standard initial-value #f)
+ (number define standard initial-value #f)
+ (cached-pango-layout define standard initial-value #f))
+
+(define (line-ink-start-index line)
+ (let ((mark (line-ink-start line)))
+ (and mark (mark-index mark))))
+
+(define (line-ink-end-index line)
+ (let ((mark (line-ink-end line)))
+ (and mark (mark-index mark))))
+
+(define-method write-instance ((line <line-ink>) port)
+ (write-instance-helper
+ "line-ink" line port
+ (lambda ()
+ (write-char #\space port)
+ (write-char #\# port)
+ (write (line-ink-number line) port)
+ (write-char #\space port)
+ (write (line-ink-start-index line) port)
+ (write-char #\- port)
+ (write (line-ink-end-index line) port))))
+
+(define-method initialize-instance ((ink <line-ink>))
+ (call-next-method ink)
+ (set-text-ink-color! ink "black"))
+
+(define-method text-ink-pango-layout ((ink <line-ink>))
+ ;; A cached pango layout is presumed to be all laid out. A cache
+ ;; miss means a PangoLayout must be re-laid-up from the buffer text,
+ ;; if the text has not changed. If the change region intersects,
+ ;; punt!
+
+ (define (salvage-pango-layout line)
+ ;; Look for a cached PangoLayout to re-use. Returns abandoned
+ ;; layouts (whose line is #f), and layouts for lines that are
+ ;; off-screen in all of the drawing's widgets.
+ (let* ((drawing (fix-ink-drawing line))
+ (widgets (fix-drawing-widgets drawing)))
+ (let loop ((caches (buffer-drawing-pango-layout-caches drawing)))
+ (if (null? caches)
+ #f
+ (let* ((cache (car caches))
+ (old (cache-line cache)))
+ (if (or (eq? old #f)
+ (every (let ((old-extent (fix-ink-extent old)))
+ (lambda (widget)
+ (or (gtk-widget-destroyed? widget)
+ (not (fix-rect-intersect?
+ old-extent
+ (fix-layout-view widget))))))
+ widgets))
+ (let ((layout (cache-layout cache)))
+ (if old (set-line-ink-cached-pango-layout! old #f))
+ (set-cache-line! cache line)
+ (set-line-ink-cached-pango-layout! line layout)
+ layout)
+ (loop (cdr caches))))))))
+
+ (define (cache-pango-layout line)
+ (let* ((drawing (fix-ink-drawing line))
+ (widget (car (fix-drawing-widgets drawing)))
+ (layout (gtk-widget-create-pango-layout widget))
+ (new (make-cache line layout)))
+ (set-buffer-drawing-pango-layout-caches!
+ drawing (cons new (buffer-drawing-pango-layout-caches drawing)))
+ (set-line-ink-cached-pango-layout! line layout)
+ layout))
+
+ ;; Do not (call-next-method ink). There is no <text-ink> method.
+ (if (unchanged? ink)
+ (or (line-ink-cached-pango-layout ink)
+ ;; When executed by the expose handler, this already runs
+ ;; without-interrupts. However there are other places
+ ;; (e.g. redraw-cursor) where this could be called. Ensure
+ ;; that the async. expose handlers do not start frobbing the
+ ;; pango-layout cache until we are done here.
+ (without-interrupts
+ (lambda ()
+ (let ((layout (or (salvage-pango-layout ink)
+ (cache-pango-layout ink))))
+ (layout-line! ink layout)
+ layout))))
+ (begin
+ (outf-error ";text-ink-pango-layout: punted "ink"\n")
+ #f)))
+
+(define (clear-cached-pango-layout line)
+ ;; This probably aught to be done without-interrupts, since it
+ ;; frobs a cache used (filled!) by the async expose handler.
+ (let ((layout (line-ink-cached-pango-layout line)))
+ (if layout
+ (let* ((drawing (fix-ink-drawing line))
+ (cache (find-cache line drawing)))
+ (set-cache-line! cache #f)
+ (set-line-ink-cached-pango-layout! line #f)))))
+\f
+(define-class (<cursor-ink> (constructor ()))
+ (<box-ink>)
+
+ ;; #t if the cursor should be drawn.
+ (visible? define standard initial-value #t)
+
+ ;; A list of one <fix-layout>. Used to blink this ink "on"
+ ;; (restore its ink-widgets list) withOUT consing.
+ (widget-list define standard))
+
+(define (guarantee-cursor-ink object)
+ (if (cursor-ink? object) object
+ (error:wrong-type-argument object "<cursor-ink>" 'guarantee-cursor-ink)))
+
+(define (cursor-ink-widget cursor)
+ (car (cursor-ink-widget-list cursor)))
+
+(define (visible! cursor visible?)
+ ;; Atomically sets cursor-ink-visible? and fix-ink-widgets.
+ (without-interrupts
+ (lambda ()
+ (if visible?
+ (if (not (cursor-ink-visible? cursor))
+ (begin
+ (set-fix-ink-widgets! cursor (cursor-ink-widget-list cursor))
+ (set-cursor-ink-visible?! cursor #t)))
+ (if (cursor-ink-visible? cursor)
+ (begin
+ (set-cursor-ink-visible?! cursor #f)
+ (set-fix-ink-widgets! cursor '())))))))
+
+(define (blink! screen cursor)
+ ;; Atomically sets CURSOR up to blink. CURSOR may be #f, in which
+ ;; case blinking will pause.
+ (without-interrupts
+ (lambda ()
+ (let ((old (gtk-screen-blinking screen)))
+ (if cursor
+ (begin
+ (if (not (eq? cursor old))
+ (set-gtk-screen-blinking! screen cursor))
+ (if (not old)
+ (signal-thread-event (gtk-screen-blinker screen)
+ (lambda () #f))))
+ (if old (set-gtk-screen-blinking! screen #f)))))))
+\f
+;;; Buffer Status
+;;
+;; The (re)layout process starts at the top of a changed buffer region
+;; and works its way to the bottom, scanning for line separators,
+;; "imaging" the content (e.g. replacing #\null with "^@"), feeding
+;; the translation (with style info!) to Pango for layup, and stacking
+;; the laid-up lines. Reading a large file may produce a change
+;; region containing hundreds of thousands of lines, taking a
+;; non-interactive amount of time to layout for display. In spite of
+;; this, the user may want to type ahead, e.g. go to the end of the
+;; buffer and start typing in a new line.
+;;
+;; To keep redisplay interactive in such a case, a thread might be
+;; spawned to do the layout. The editor thread can then continue with
+;; event (keypress) processing. The new thread works on the buffer
+;; (re)drawing, and shows its progress by animating a progress/status
+;; indicator in the drawing. The indicator might report the number of
+;; bytes remaining to be (re)parsed, with newly re-parsed lines
+;; appearing above it. When the point is at buffer indices that are
+;; not (yet) laid out, the cursor appears after the progress
+;; indicator. Any typeahead will be displayed... eventually.
+
+(define-class (<buffer-status> (constructor add-buffer-status (drawing) 1))
+ (<box-ink>)
+ (text-ink define standard))
+\f
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ ARGS ...) (if %trace? (outf-error ARGS ...)))))
+
+(define %trace2? #f)
+
+(define-syntax %trace2
+ (syntax-rules ()
+ ((_ ARGS ...) (if %trace2? (outf-error ARGS ...)))))
+
+(initialize-package!)
projects / mit-scheme.git / commitdiff