From: Matt Birkholz Date: Fri, 3 Aug 2012 05:51:41 +0000 (-0700) Subject: Merge branch 'Gtk' (pre Gtk 3) into Gtk-Screen. X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~74 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7ce011bdff55968034ec0b59ae11ea0d2d516a47;p=mit-scheme.git Merge branch 'Gtk' (pre Gtk 3) into Gtk-Screen. --- 7ce011bdff55968034ec0b59ae11ea0d2d516a47 diff --cc src/edwin/edwin.pkg index 69c01ade6,fd97a8464..5bd227b04 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@@ -1019,9 -987,8 +1019,10 @@@ USA (parent (edwin screen)) (export (edwin) resize-screen) + (import (edwin keyboard) + keyboard-peek-busy-no-hang) (import (runtime primitive-io) + %channel-read channel-type=terminal? have-select? terminal-get-state diff --cc src/edwin/tterm.scm index 3e17f724f,9ae354ec7..68bdb21ac --- a/src/edwin/tterm.scm +++ b/src/edwin/tterm.scm @@@ -232,85 -234,101 +234,104 @@@ USA #T) ((fix:= n 0) ;;(error "Reached EOF in keyboard input.") - #F) - (else - (error "Illegal return value:" n)))))) - (read-char - (lambda (block?) - (if (read-more? block?) - (parse-key) - #F))) - (read-event - (lambda (block?) - (or (read-char #f) - (let loop () - (cond (inferior-thread-changes? event:interrupt) - ((process-output-available?) event:process-output) - ((not have-select?) - (and block? (read-event block?))) - (else - (case (test-for-io-on-channel channel 'READ block?) - ((#F) #f) - ((PROCESS-STATUS-CHANGE) event:process-status) - ((INTERRUPT) (loop)) - (else (read-event block?))))))))) - (guarantee-result - (lambda () - (let ((event (read-event #t))) - (cond ((char? event) event) - ((special-key? event) event) - ((process-change-event event) - => (lambda (flag) - (make-input-event - (if (eq? flag 'FORCE-RETURN) 'RETURN 'UPDATE) - update-screens! #f))) - (else (guarantee-result)))))) - (consume! - (lambda (bytes) - (set! start (fix:+ start bytes)) - (cond ((fix:>= start end) ; all consumed - (set! end 0) - (set! start 0)) + #F))))) + (match-event ; -> #F or match (char or pair) or input event + (named-lambda (match-event block?) + (let loop () + (or (begin + (read-more? #f) + (match-key)) + ;; Atomically poll async event sources and block. + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (cond (inferior-thread-changes? + (set-interrupt-enables! mask) + (or (->update-event (accept-thread-output)) + (loop))) + ((process-output-available?) + (set-interrupt-enables! mask) + (or (->update-event (accept-process-output)) + (loop))) + ((process-status-changes?) + (set-interrupt-enables! mask) + (or (->update-event (handle-process-status-changes)) + (loop))) + ((not have-select?) + (set-interrupt-enables! mask) + (and block? (loop))) + (incomplete-pending + ;; Must busy-wait. + (set-interrupt-enables! mask) + (loop)) + (block? + (read-more? #t) + (set-interrupt-enables! mask) + (loop)) + (else + (set-interrupt-enables! mask) + #f))))))) + (->update-event + (named-lambda (->update-event redisplay?) + (and redisplay? + (make-input-event + (if (eq? redisplay? 'FORCE-RETURN) 'RETURN 'UPDATE) + update-screens! #f)))) + (consume-match! + (named-lambda (consume-match! match) + (cond ((fixnum? match) + (set! start (fix:1+ start))) + ((input-event? match) + unspecific) + ((pair? match) + (set! start (fix:+ start (string-length (car match))))) + (else (error "Inedible match:" match))) + (if (fix:< end start) + (error "Overconsumption:" buffer start end match)) + (cond ((fix:= start end) ; all consumed + (if (not (fix:zero? start)) + (set! start 0)) + (if (not (fix:zero? end)) + (set! end 0))) ((fix:>= start input-buffer-size) - (substring-move-left! string start end string 0) + (substring-move-left! buffer start end buffer 0) (set! end (fix:- end start)) (set! start 0))) - (set! incomplete-pending #F) - unspecific))) + (set! incomplete-pending #f))) + (->event + (named-lambda (->event match) + (cond ((eq? match #f) + #F) + ((fixnum? match) + ;; Assume the eighth bit is a meta bit. + (if (fix:< match #x80) + (make-char match 0) + (make-char (fix:and match #x7F) char-bit:meta))) + ((input-event? match) + match) + ((pair? match) + (cdr match)) + (else (error "Bogus input match:" match)))))) (values - (lambda () ;halt-update? + (named-lambda (halt-update?) (or (fix:< start end) - (read-char #f))) - (lambda (timeout) ;peek-no-hang + (read-more? #f))) - (named-lambda (peek-no-hang) - (let ((event (->event (match-event #f)))) - (if (input-event? event) - (begin - (apply-input-event event) - #f) - event))) ++ (named-lambda (peek-no-hang msec) + (keyboard-peek-busy-no-hang + (lambda () - (or (parse-key) - (let ((event (read-event #f))) - (if (fix:fixnum? event) - (begin - (process-change-event event) - #f) - event)))) - timeout)) - (lambda () ;peek - (or (parse-key) - (guarantee-result))) - (lambda () ;read - (let ((event (or (parse-key) (guarantee-result)))) - (consume! len) - event)))))) - ++ (let ((event (->event (match-event #f)))) ++ (if (input-event? event) ++ (begin ++ (apply-input-event event) ++ #f) ++ event))) ++ msec)) + (named-lambda (peek) + (->event (match-event #t))) + (named-lambda (read) + (let ((match (match-event #t))) + (consume-match! match) + (->event match))))))) (define-integrable input-buffer-size 16) - (define-integrable event:process-output -2) - (define-integrable event:process-status -3) - (define-integrable event:interrupt -4) - - (define (process-change-event event) - (cond ((fix:= event event:process-output) (accept-process-output)) - ((fix:= event event:process-status) (handle-process-status-changes)) - ((fix:= event event:interrupt) (accept-thread-output)) - (else (error "Illegal change event:" event)))) (define (signal-interrupt!) (signal-thread-event editor-thread diff --cc src/gtk-screen/gtk-screen.pkg index f3041b5fd,000000000..d48b9892a mode 100644,000000..100644 --- a/src/gtk-screen/gtk-screen.pkg +++ b/src/gtk-screen/gtk-screen.pkg @@@ -1,196 -1,0 +1,195 @@@ +#| -*-Scheme-*- + +Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz + +This file is part of 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. + +|# + +;;;; Gtk-Screen System Packaging + +(global-definitions "../runtime/runtime") +(global-definitions "../sos/sos") +(global-definitions "../gtk/gtk") +(global-definitions "../edwin/edwin") + +(define-package (edwin screen gtk-screen) + (files "gtk-screen") + (parent (edwin screen)) + (export () + set-gtk-screen-hooks!) + (export (edwin) + ;; edwin-variable$x-cut-to-clipboard + ;; edwin-variable$x-paste-from-clipboard + ;; os/interprogram-cut + ;; os/interprogram-paste + ;; x-root-window-size + ;; x-screen-ignore-focus-button? + ;; x-selection-timeout + ;; xterm-screen/flush! + ;; xterm-screen/grab-focus! + ) + (export (edwin x-commands) + ;; screen-display + ;; screen-xterm + ;; xterm-screen/set-icon-name + ;; xterm-screen/set-name + ) - (import (runtime subprocess) - hook/subprocess-status-change) ++ (import (runtime thread) ++ register-subprocess-status-change-event) + (import (edwin process) + hook/inferior-process-output) + (import (edwin window) + editor-frame-root-window + window-inferiors find-inferior window-next + combination? combination-vertical? combination-child + (%window-x-size window-x-size) + (%window-y-size window-y-size) + %set-window-x-size! + %set-window-y-size! + inferior-window + inferior-x-start + inferior-y-start + %set-inferior-start! + editor-frame + buffer-frame? + frame-modeline-inferior + frame-text-inferior + %window-buffer + %window-char-image-strings + %window-force-redraw? + %window-group + %window-point-index + %set-window-point-index! + %window-point-moved? + %set-window-point-moved?! + %window-start-mark + %set-window-start-mark! + %window-tab-width) + (import (gtk pango) + pangos->pixels) + (import (gtk gtk-object) + gtk-object-destroy-callback + gtk-container-reverse-children) + (import (gtk fix-layout) + fix-widget-geometry + + drawing-damage + fix-drawing-display-list + fix-drawing-extent + fix-ink-expose-callback + fix-ink-extent + text-ink-pango-layout + + make-fix-rect copy-fix-rect fix-rect-string + fix-rect-x fix-rect-y fix-rect-width fix-rect-height + fix-rect-min-x fix-rect-max-x fix-rect-min-y fix-rect-max-y + set-fix-rect-size! set-fix-rect-position! + fix-rect-intersect? fix-rect-union!) + (import (gtk) + gdk-key-state->char-bits gdk-keyval->name + gobject-alien gobject-unref! + gdk-window-process-updates + + gtk-object-destroyed? gtk-object-destroy + + gtk-widget? gtk-widget-parent + gtk-widget-grab-focus + gtk-widget-show gtk-widget-show-all + gtk-widget-error-bell + gtk-widget-queue-draw + gtk-widget-font set-gtk-widget-font! + gtk-widget-get-pango-context + gtk-widget-create-pango-layout + gtk-widget-set-size-request + gtk-widget-text-color gtk-widget-base-color + set-gtk-widget-text-color! set-gtk-widget-base-color! + set-gtk-widget-fg-color! set-gtk-widget-bg-color! + + gtk-container? + gtk-container-children gtk-container-add gtk-container-remove + gtk-container-set-border-width + + gtk-scrolled-window? gtk-scrolled-window-new + gtk-scrolled-window-set-policy + gtk-scrolled-window-set-placement + + gtk-hbox? gtk-hbox-new + gtk-vbox? gtk-vbox-new + gtk-box-pack-end + + gtk-window-new + gtk-window-present + gtk-window-set-geometry-hints + gtk-window-set-title + gtk-window-set-opacity + gtk-window-parse-geometry + + pango-layout-get-pixel-extents + pango-layout-index-to-pos + pango-layout-set-text + + pango-context-get-metrics + pango-context-spacing + + pango-font-description-from-string + pango-font-description-to-string + pango-font-description-free + pango-font-metrics-get-ascent pango-font-metrics-get-descent + pango-font-metrics-get-approximate-char-width + pango-font-metrics-unref + + fix-widget? + fix-widget-new-geometry-callback fix-widget-realize-callback - set-fix-widget-size! + set-fix-widget-map-handler! + set-fix-widget-unmap-handler! + set-fix-widget-enter-notify-handler! + set-fix-widget-leave-notify-handler! + set-fix-widget-focus-change-handler! + set-fix-widget-visibility-notify-handler! + set-fix-widget-key-press-handler! + set-fix-widget-motion-handler! + set-fix-widget-button-handler! + + fix-layout? + fix-layout-view fix-layout-drawing set-fix-layout-drawing! + fix-layout-scroll-step set-fix-layout-scroll-step! + fix-layout-scroll-to! fix-layout-scroll-nw! + + fix-resizer? + make-fix-resizer + fix-resizer-before set-fix-resizer-before! + fix-resizer-after set-fix-resizer-after! + + guarantee-fix-drawing + make-fix-drawing fix-drawing-widgets + set-fix-drawing-size! + fix-drawing-add-ink! + + fix-ink? + fix-ink-drawing + fix-ink-widgets set-fix-ink-widgets! + fix-ink-remove! + + text-ink? set-text-ink-position! + + simple-text-ink? make-simple-text-ink + simple-text-ink-text set-simple-text-ink-text! + + set-box-ink! set-box-ink-position! + set-box-ink-shadow!)) diff --cc src/gtk-screen/gtk-screen.scm index 9583d1c82,000000000..295daf28b mode 100644,000000..100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@@ -1,2504 -1,0 +1,2510 @@@ +#| -*-Scheme-*- + +Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz + +This file is part of 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 for Edwin. +;;; Package: (edwin screen gtk-screen) + +(define-class ( + (constructor %make-gtk-screen (toplevel editor-thread) no-init)) + () ;; TODO: could also be a , replacing toplevel! + + ;; The toplevel . 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 . + (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) + + ;; This does not get any re-allocations done. + ;;(gtk-container-set-resize-mode toplevel 'immediate) + + (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))) + ;; This allows the user to resize to smaller sizes. + (gtk-window-set-geometry-hints toplevel toplevel + 'min-width 100 'min-height 100))))) + +(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 ) x-size y-size) + (%trace "; (set-screen-size! ) "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))))) + +(define-method screen-beep ((screen )) + (gtk-widget-error-bell (gtk-screen-toplevel screen))) + +(define-method screen-enter! ((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 )) + (%trace "; screen-exit! "screen"\n") + (set-gtk-screen-in-focus?! screen #f) + (update-blinking screen)) + +(define-method screen-discard! ((screen )) + (set! screen-list (delq! screen screen-list)) + (gtk-object-destroy (gtk-screen-toplevel screen))) + +(define-method screen-modeline-event! ((screen ) window type) + (%trace "; screen-modeline-event! "screen" "window" "type"\n")) + +;;; 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 ) + 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 ) + 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 ) + 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 ) 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 ) frame mark) + (%trace "; screen/window-mark->x "screen" "frame" "mark"\n") + 0 ; Need a real X??? + ) + +(define-method screen/window-mark->y ((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 ) + 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 ) frame) + (screen/window-mark->x screen frame (window-point frame))) + +(define-method screen/window-point-y ((screen ) frame) + (screen/window-mark->y screen frame (window-point frame))) + +(define-method screen/window-point-coordinates ((screen ) frame) + (screen/window-mark->coordinates screen frame (window-point frame))) + +(define-method screen/window-coordinates->mark ((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))) + +;;; 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 (timeout) ;peek-no-hang - (%trace2 ";peek-no-hang "timeout"\n") - (let ((event (thread-queue/peek-no-hang event-queue timeout))) - (%trace2 ";peek-no-hang "timeout" => "event"\n") ++ (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 via (runtime subprocess)hook/subprocess-status-change - ;; whenever ANY child process changes status. ++ ;; 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) + ((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. + )))) + +;;; 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) - (set! hook/subprocess-status-change gtk-screen-process-status-change)) ++ (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) + +(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) + (let ((top-box (gtk-vbox-new #f 0))) + (gtk-container-add toplevel top-box) + (%trace "; -init "root" in "top-box"\n") + (re-pack-windows! (%reversed-children root) + '() top-box #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")) + (let ((top-box (car top-children))) + (%trace "; -pack "root" into "top-box"\n") + (re-pack-windows! (%reversed-children root) + (gtk-container-children top-box) top-box #f "--") + (for-each-text-widget screen update-widget-buffer) + (%trace "; -show-all "toplevel"\n") + (gtk-widget-show-all toplevel) + (%trace "; update-widgets done\n"))))) + + (define (re-pack-windows! windows widgets box resizer prefix) + (cond + + ((and (not (pair? windows)) + (not (pair? widgets))) + (%trace "; "prefix"done\n")) + + ((not (pair? windows)) ;extra children + (for-each (lambda (child) + (%trace "; "prefix"destroying extra "child"\n") + (gtk-object-destroy child)) + widgets) + (%trace "; "prefix"done, tossed extra children\n")) + + ((not (pair? widgets)) + ;; and (pair? windows) -- insufficient children + (pack-new! windows box resizer prefix)) + + (else ;; (and (pair? widgets) (pair? windows)) + (let ((widget (car widgets)) + (window (car windows))) + (cond + + ;; Exact combo. match. + ((and (combination? window) + (not (buffer-frame-widget? widget)) + (if (combination-vertical? window) + (gtk-vbox? widget) + (gtk-hbox? widget))) + (%trace "; "prefix"matched "window" to "widget"\n") + (re-pack-windows! (%reversed-children window) + (gtk-container-children widget) + widget #f (string-append prefix "--")) + (re-pack-resizer! windows widgets box resizer prefix)) + + ;; Exact leaf match. + ((and (buffer-frame? window) + (buffer-frame-widget? widget) + (let ((text (buffer-frame-widget-text* widget))) + (and text + (eq? window (text-widget-buffer-frame text)) + text))) + => (lambda (text) + (%trace "; "prefix"matched "window" to " + widget" (containing "text")\n") + (re-size! text window) + (re-pack-resizer! windows widgets box resizer prefix))) + + (else + ;; Children were added/removed. Must remove the rest + ;; before adding any, to get the ordering right. For + ;; now, just remove one, in case one child was removed + ;; and we will match the next... + (%trace "; "prefix"destroying "widget + ", which mismatched "window"\n") + (gtk-object-destroy widget) + (re-pack-windows! windows (cdr widgets) box resizer prefix))))))) + + (define (re-pack-resizer! windows widgets box resizer prefix) + ;; (car WINDOWS) matched (car WIDGETS) and was re-packed. Now + ;; link the latter to the previous RESIZER, find or add the next + ;; resizer (if needed), then tail-call re-pack-windows! on the + ;; rest. + (if (and resizer + (not (eq? (car widgets) (fix-resizer-before resizer)))) + (set-fix-resizer-before! resizer (car widgets))) + + (if (and (gtk-hbox? box) (pair? (cdr windows))) + ;; Need resizer. + (let ((resizer (and (pair? (cdr widgets)) + (fix-resizer? (cadr widgets)) + (cadr widgets)))) + (if resizer + (re-pack-windows! (cdr windows) (cddr widgets) box resizer prefix) + (let ((new (make-fix-resizer (gtk-screen-char-width screen) -1))) + (set-fix-resizer-after! new box) + (gtk-box-pack-end box new #f #f 0) + (for-each + (lambda (w) + (outf-error "; "prefix"destroying unexpected "w"\n") + (gtk-object-destroy w)) + (cdr widgets)) + (re-pack-windows! (cdr windows) '() box new prefix)))) + ;; Need NO resizer. + (re-pack-windows! (cdr windows) (cdr widgets) box #f prefix))) + + (define (re-size! widget window) + (let ((area (fix-widget-geometry widget)) + (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 re-size! "widget ++ (%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") - (set-fix-widget-size! widget new-width new-height)))))))) ++ (gtk-widget-set-size-request widget ++ new-width new-height)))))))) + + (define (pack-new! windows box resizer prefix) + (let ((window (car windows))) + (%trace "; "prefix"pack-new! "window" in "box"\n") + (cond + ((combination? window) + (let ((new (if (combination-vertical? window) + (gtk-vbox-new #f 0) + (gtk-hbox-new #f 0))) + (new-prefix (string-append prefix "--"))) + (pack-new! (%reversed-children (car windows)) new #f new-prefix) + (gtk-box-pack-end box new #t #t 0) + (%trace "; "prefix"packed "new" in "box"\n") + (if resizer (set-fix-resizer-before! resizer new)) + (if (and (gtk-hbox? box) (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-box-pack-end box new-resizer #f #f 0) + (pack-new! (cdr windows) box new-resizer prefix)) + ;; Need NO resizer. + (if (pair? (cdr windows)) + (pack-new! (cdr windows) box #f prefix))))) + + ((buffer-frame? window) + (let ((vbox (make-buffer-frame-widget)) + (text (make-text-widget screen + (%text-x-size window) + (%text-y-size window))) + (scroller (gtk-scrolled-window-new)) + (modeline (if (not (frame-modeline-inferior window)) + #f + (make-modeline-widget screen))) + (y-step (fix:+ (gtk-screen-line-height screen) + (gtk-screen-line-spacing screen))) + (x-step (gtk-screen-char-width screen))) + (set-text-widget-buffer-frame! text window) + (set-text-widget-modeline! text modeline) + (set-fix-layout-scroll-step! text x-step y-step) + (gtk-scrolled-window-set-policy scroller 'auto 'always) + (gtk-scrolled-window-set-placement scroller 'bottom-left) + (gtk-container-add scroller text) + (if (not modeline) + ;; No modeline: the window/text-widget should NOT expand. + (begin + ;; This is also necessary! Why??? + (gtk-widget-set-size-request scroller + (%widget-x-size window screen) + (%widget-y-size window screen)) + (gtk-box-pack-end vbox scroller #f #f 0) + (gtk-box-pack-end box vbox #f #f 0) + (%trace "; "prefix"packed "vbox" into "box"\n")) + ;; With modeline: vbox and scroller SHOULD expand. + (begin + (gtk-box-pack-end vbox modeline #f #f 0) + (gtk-box-pack-end vbox scroller #t #t 0) + (gtk-box-pack-end box vbox #t #t 0) + (%trace "; "prefix"packed "vbox" into "box"\n"))) + (if resizer (set-fix-resizer-before! resizer vbox)) + (if (and (gtk-hbox? box) (pair? (cdr windows))) + ;; Need resizer. + (let ((new-resizer + (make-fix-resizer (gtk-screen-char-width screen) -1))) + (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)) + ;; Need NO resizer. + (if (pair? (cdr windows)) + (pack-new! (cdr windows) box #f prefix))))) + (else (error "Unexpected Edwin window:" window))))) + + (main)) + +(define-integrable (typein-widget screen) + (let* ((top-box (car (gtk-container-reverse-children + (gtk-screen-toplevel screen)))) + ;; Typein widget is always added first -- last in the reverse list. + (typein-frame (last (gtk-container-reverse-children top-box)))) + (any-child text-widget? typein-frame))) + +(define (%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)))) + +;;; Text and Modeline Widgets + +(define-class + () + + (screen define standard)) + +(define-class ( + (constructor make-text-widget (screen) (x-size y-size))) + () + + (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 ") + +(define-method initialize-instance ((widget ) x-size y-size) +;;; (%trace ";(initialize-instance ) "widget +;;; " "x-size" "y-size"\n") + (let ((screen (edwin-widget-screen widget))) + (call-next-method widget + (x-size->width screen x-size) + (y-size->height screen y-size))) + (let ((drawing (make-fix-drawing))) +;;; (%trace "; drawing: "drawing"\n") + (let ((ink (make-simple-text-ink))) + (set-simple-text-ink-text! ink widget "Initial override message.") + (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-object-destroy-callback ((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 )) + (%trace ";(fix-widget-realize-callback ) "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) + ;; Since this is a text widget, fg/bg should be text/base. + (set-gtk-widget-fg-color! widget (gtk-widget-text-color widget)) + (set-gtk-widget-bg-color! widget (gtk-widget-base-color widget))) + +(define-method fix-widget-new-geometry-callback ((widget )) + (%trace ";(fix-widget-new-geometry-callback ) "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 ( (constructor make-modeline-widget (screen))) + ()) + +(define-method initialize-instance ((widget )) +;;; (%trace ";(initialize-instance ) "widget"\n") + (let ((screen (edwin-widget-screen widget))) + (call-next-method widget -1 (y-size->height screen 1))) + (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.--------------------------------") + (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 )) + (%trace ";(fix-widget-realize-callback ) "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) + ;; Since this is a modeline widget, fg/bg (& text/base) should be base/text. + (let ((text-color (gtk-widget-text-color widget)) + (base-color (gtk-widget-base-color widget))) + (set-gtk-widget-text-color! widget base-color) + (set-gtk-widget-base-color! widget text-color) + (set-gtk-widget-fg-color! widget base-color) + (set-gtk-widget-bg-color! widget text-color))) + +(define-class ( (constructor ())) + () + + ;; This one just "marks" a gtk-container as the type that holds a + ;; text-widget and its modeline (and button bars?) together. If the + ;; frame has no modeline (nor button bars? :-) a lone scroller STILL + ;; gets wrapped. + ) + +(define-method initialize-instance ((widget )) +;;; (%trace ";(initialize-instance ) "widget"\n") + (call-next-method widget #f 0)) + +;; Assume there is one text-widget in a buffer-frame-widget. +(define-integrable buffer-frame-widget-text* any-text-widget) + +;;; Incremental Redisplay + +;; Drawing a Buffer +;; +;; At its simplest, drawing a buffer is a process of searching for +;; the "lines" between newlines and creating a for +;; each. The 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 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. +;; +;; 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 ) display-style) + (%trace "; (update-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! ) 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! ) 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! ) done: finished\n") + #t) + (begin + (%trace "; (update-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 ) window display-style) + (%trace "; (update-screen-window! ) "screen" "window"\n") + (let ((v (update-screens! display-style))) + (%trace "; (update-screen-window! ) "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)))))) + +(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)))) + + ;; 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))))) + +(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) + (set-box-ink-shadow! cursor 'etched-in) + (visible! cursor #t)) + ((and (text-widget? widget) + (not (text-widget-modeline widget))) + (set-box-ink-shadow! cursor 'etched-out) + (visible! cursor #f)) + (else ;; text widget + (set-box-ink-shadow! cursor 'etched-out) + (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)))) + +;;; Buffer Drawings and Buffer Lines + +(define-class ( + (constructor make-buffer-drawing + (buffer tab-width char-image-strings) + no-init)) + () + + ;; 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: (|#f + ;; . ). 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 ( (constructor ())) + () + + (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 ) 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 text-ink-pango-layout ((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-object-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 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))))) + +(define-class ( (constructor ())) + () + + ;; #t if the cursor should be drawn. + (visible? define standard initial-value #t) + + ;; A list of one . Used to blink this ink "on" + ;; (restore its ink-widgets list) withOUT consing. + (widget-list define standard)) + +#;(define-method initialize-instance ((ink )) + (call-next-method ink) + (set-box-ink-shadow! ink 'etched-in)) + +(define (guarantee-cursor-ink object) + (if (cursor-ink? object) object + (error:wrong-type-argument object "" '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))))))) + +;;; 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 ( (constructor add-buffer-status (drawing) 1)) + () + (text-ink define standard)) + +(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!) diff --cc src/gtk/fix-layout.scm index 05810e6eb,98a695d04..301856b72 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@@ -1648,31 -1576,28 +1576,44 @@@ USA (define-generic text-ink-pango-layout (ink)) (define-method fix-ink-expose-callback ((ink ) widget window area) - (declare (ignore area)) + (declare (ignore window area)) (%trace2 ";drawing "ink" on "widget"\n") - (let ((view (fix-layout-view widget)) - (rect (fix-ink-extent ink))) - (let ((x (fix:- (fix-rect-x rect) (fix-rect-x view))) - (y (fix:- (fix-rect-y rect) (fix-rect-y view))) - (layout (text-ink-pango-layout ink))) - (if layout - (with-text-gc - ink widget - (lambda (gc) - (C-call "gdk_draw_layout" window gc x y - (gobject-alien layout)))))))) - - (define (with-text-gc ink widget receiver) - (with-gc (text-options ink widget) widget receiver)) - - (define (text-options ink widget) - (append-map! - (lambda (entry) - (case (car entry) - ((FOREGROUND) `((FOREGROUND . ,(allocate-color! widget (cdr entry))))) - (else '()))) - (draw-ink-options ink))) + (let ((layout (text-ink-pango-layout ink))) + (if layout + (let ((view (fix-layout-view widget)) + (rect (fix-ink-extent ink))) + (let ((x (fix:- (fix-rect-x rect) (fix-rect-x view))) + (y (fix:- (fix-rect-y rect) (fix-rect-y view))) + (cr (gdk-cairo-create (fix-widget-window widget)))) + (set-text-options! cr ink widget) ++ ++ ;; gdk-cairo-create leaves source rgb "black"? ++ (if (not (assq 'COLOR (draw-ink-options ink))) ++ (let ((alien (gobject-alien widget))) ++ (let ((state (C-> alien "GtkWidget state")) ++ (gdkcolor (make-alien '|GdkColor|))) ++ (define-integrable (->flo c) ++ (flo:/ (->flonum c) 65535.)) ++ (C-> alien "GtkWidget style" gdkcolor) ++ (C-> gdkcolor "GtkStyle fg" gdkcolor) ++ (C-array-loc! gdkcolor "GdkColor" state) ++ (C-call "cairo_set_source_rgb" cr ++ (->flo (C-> gdkcolor "GdkColor red")) ++ (->flo (C-> gdkcolor "GdkColor green")) ++ (->flo (C-> gdkcolor "GdkColor blue")))))) ++ + (C-call "cairo_move_to" cr (->flonum x) (->flonum y)) + (C-call "pango_cairo_show_layout" cr (gobject-alien layout)) + (cairo-destroy cr)))))) + + (define (set-text-options! cr ink widget) + (for-each + (lambda (entry) + (let ((name (car entry)) + (value (cdr entry))) + (case name + ((COLOR) (set-source-rgb cr value widget))))) + (draw-ink-options ink))) (define (set-text-ink-position! ink x y) (guarantee-fixnum x 'set-text-ink-position!) diff --cc src/runtime/thread.scm index cb9f7f97a,4e41e456c..a22d3faaa --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@@ -581,6 -586,6 +586,19 @@@ USA (lambda () (%deregister-io-thread-event registration) (%maybe-toggle-thread-timer))))))) ++ ++(define (register-subprocess-status-change-event event) ++ (guarantee-procedure-of-arity event 1 'register-subprocess-status-change-event) ++ (without-interrupts ++ (lambda () ++ (%register-io-thread-event ++ 'PROCESS-STATUS-CHANGE ++ 'READ ++ (current-thread) ++ event ++ #t ;permanent? ++ #f ;front? ++ )))) (define (permanently-register-io-thread-event descriptor mode thread event) (register-io-thread-event-1 descriptor mode thread event