Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv27201

Modified Files: text-editor-gadget.lisp gadgets.lisp Log Message: Attempt at cleaning up the text-field and text-editor gadget mess. Drei/Goatee selection now more elegant and complex setups (scrolling, minibuffer for Drei) now handled well without relying on undocumented McCLIM quirks. The various size-specification-features should also work now.

--- /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2007/02/07 12:44:17 1.8 +++ /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2007/08/21 22:09:01 1.9 @@ -27,30 +27,89 @@

;;; This file contains the concrete implementation of the text-field ;;; and text-editor gadgets. It is loaded rather late, because it -;;; requires Drei. +;;; requires Drei. Half of the complexity here is about working around +;;; annoying Goatee quirks, generalising it to three editor substrates +;;; is nontrivial.

(in-package :clim-internals)

-;;; ------------------------------------------------------------------------------------------ -;;; 30.4.8 The concrete text-field Gadget +;;; The text editor gadget(s) is implemented as a class implementing +;;; the text editor gadget protocol, but containing an editor +;;; substrate object that takes care of the actual editing logic, +;;; redisplay, etc. The substrates need to be gadgets themselves and +;;; are defined here.

-(defclass text-field-pane (text-field - drei:drei-gadget-pane) - ((previous-focus :accessor previous-focus :initform nil - :documentation - "The pane that previously had keyboard focus") - (activation-gestures :accessor activation-gestures - :initarg :activation-gestures - :documentation "gestures that cause the -activate callback to be called")) - (:default-initargs - :activation-gestures *standard-activation-gestures*)) +(defparameter *default-text-field-text-style* + (make-text-style :fixed :roman :normal)) + +(defclass editor-substrate-mixin (value-gadget) + ((activation-gestures :reader activation-gestures + :initarg :activation-gestures) + (user :reader user-gadget + :initarg :user-gadget + :documentation "The editor gadget using this editor substrate." + :initform (error "Editor substrates must have a user."))) + (:documentation "A mixin class for text editor gadget substrates.") + (:default-initargs :activation-gestures '())) + +(defmethod gadget-id ((gadget editor-substrate-mixin)) + (gadget-id (user-gadget gadget))) + +(defmethod (setf gadget-id) (value (gadget editor-substrate-mixin)) + (setf (gadget-id (user-gadget gadget)) value)) + +(defmethod gadget-client ((gadget editor-substrate-mixin)) + (gadget-client (user-gadget gadget))) + +(defmethod (setf gadget-client) (value (gadget editor-substrate-mixin)) + (setf (gadget-client (user-gadget gadget)) value)) + +(defmethod gadget-armed-callback ((gadget editor-substrate-mixin)) + (gadget-armed-callback (user-gadget gadget))) + +(defmethod gadget-disarmed-callback ((gadget editor-substrate-mixin)) + (gadget-disarmed-callback (user-gadget gadget))) + +(defclass text-field-substrate-mixin (editor-substrate-mixin) + () + (:documentation "A mixin class for editor substrates used for text field gadgets."))

-(defmethod initialize-instance :after ((object text-field-pane) &key value) - ;; Why doesn't `value-gadget' do this for us? - (setf (gadget-value object) value)) +(defclass text-editor-substrate-mixin (editor-substrate-mixin) + ((ncolumns :reader text-editor-ncolumns + :initarg :ncolumns + :initform nil + :type (or null integer)) + (nlines :reader text-editor-nlines + :initarg :nlines + :initform nil + :type (or null integer))) + (:documentation "A mixin class for editor substrates used for text editor gadgets.")) + +;;; Now, define the Drei substrate. + +(defclass drei-editor-substrate (drei:drei-gadget-pane + editor-substrate-mixin) + () + (:documentation "A class for Drei-based editor substrates."))

-(defmethod compose-space ((pane text-field-pane) &key width height) +(defmethod (setf gadget-value) :after (value (gadget drei-editor-substrate) + &key invoke-callback) + (declare (ignore invoke-callback)) + ;; Hm! I wonder if this can cause trouble. I think not. + (drei:display-drei gadget)) + +(defclass drei-text-field-substrate (text-field-substrate-mixin + drei-editor-substrate) + () + (:documentation "The class for Drei-based text field substrates.")) + +(defmethod drei:handle-gesture ((drei drei-text-field-substrate) gesture) + (if (with-activation-gestures ((activation-gestures drei)) + (activation-gesture-p gesture)) + (activate-callback drei (gadget-client drei) (gadget-id drei)) + (call-next-method))) + +(defmethod compose-space ((pane drei-text-field-substrate) &key width height) (declare (ignore width height)) (with-sheet-medium (medium pane) (let ((as (text-style-ascent (medium-text-style medium) medium)) @@ -59,44 +118,14 @@ (let ((width w) (height (+ as ds))) (make-space-requirement :height height :max-height height :min-height height - :min-width width :width width))))) + :min-width width :width width)))))

-(defmethod drei:handle-gesture ((drei text-field-pane) gesture) - (if (with-activation-gestures ((activation-gestures drei)) - (activation-gesture-p gesture)) - (activate-callback drei (gadget-client drei) (gadget-id drei)) - (call-next-method))) - -(defmethod allocate-space ((pane text-field-pane) w h) - (resize-sheet pane w h)) - -;;; ------------------------------------------------------------------------------------------ -;;; 30.4.9 The concrete text-editor Gadget +(defclass drei-text-editor-substrate (text-editor-substrate-mixin + drei-editor-substrate) + () + (:documentation "The class for Drei-based text editor substrates."))

-(defclass text-editor-pane (text-editor drei:drei-gadget-pane) - ((ncolumns :type (or null integer) - :initarg :ncolumns - :initform nil - :accessor text-editor-ncolumns) - (nlines :type (or null integer) - :initarg :nlines - :initform nil - :accessor text-editor-nlines)) - (:default-initargs :activation-gestures nil)) - -(defmethod initialize-instance :after ((object text-editor-pane) &key value) - ;; Why doesn't `value-gadget' do this for us? - (setf (gadget-value object) value)) - -(defmethod make-pane-1 :around (fm (frame application-frame) - (type (eql 'text-editor)) - &rest args &key) - (apply #'make-pane-1 fm frame :drei - :drei-class 'text-editor-pane - :minibuffer t - args)) - -(defmethod compose-space ((pane text-editor-pane) &key width height) +(defmethod compose-space ((pane drei-text-editor-substrate) &key width height) (with-sheet-medium (medium pane) (let* ((text-style (medium-text-style medium)) (line-height (+ (text-style-height text-style medium) @@ -113,86 +142,72 @@ (height (if nlines (+ (* nlines line-height)) height))) - (list :width width :max-width width :min-width width - :height height :max-height height :min-height height))))))) + (list + :width width :max-width width :min-width width + :height height :max-height height :min-height height)))))))

-(defmethod allocate-space ((pane text-editor-pane) w h) +(defmethod allocate-space ((pane drei-text-editor-substrate) w h) (resize-sheet pane w h))

-;;; ------------------------------------------------------------------------------------------ -;;; 30.4.9 Alternative Goatee-based implementation - -(defparameter *default-text-field-text-style* - (make-text-style :fixed :roman :normal)) +;;; Now, define the Goatee substrate.

-(defclass goatee-text-field-pane (text-field - standard-extended-output-stream - standard-output-recording-stream - basic-pane) - ((area :accessor area :initform nil - :documentation "The Goatee area used for text editing.") - (previous-focus :accessor previous-focus :initform nil - :documentation - "The pane that previously had keyboard focus") - (activation-gestures :accessor activation-gestures - :initarg :activation-gestures - :documentation "gestures that cause the - activate callback to be called")) +(defclass goatee-editor-substrate (editor-substrate-mixin + text-field + clim-stream-pane) + ((area :accessor area + :initform nil + :documentation "The Goatee area used for text editing.") + ;; This hack is necessary because the Goatee editing area is not + ;; created until the first redisplay... yuck. + (value :documentation "The initial value for the Goatee area.")) (:default-initargs - :text-style *default-text-field-text-style* - :activation-gestures *standard-activation-gestures*)) + :text-style *default-text-field-text-style*))

-(defmethod initialize-instance :after ((gadget text-field) &rest rest) - (unless (getf rest :normal) - (setf (slot-value gadget 'current-color) +white+ - (slot-value gadget 'normal) +white+))) - -(defmethod initialize-instance :after ((pane goatee-text-field-pane) &rest rest) +(defmethod initialize-instance :after ((pane goatee-editor-substrate) &rest rest) (declare (ignore rest)) - #-nil (setf (medium-text-style (sheet-medium pane)) - (slot-value pane 'text-style))) + (setf (medium-text-style (sheet-medium pane)) + (slot-value pane 'text-style)))

;; Is there really a benefit to waiting until the first painting to ;; create the goatee instance? Why not use INITIALIZE-INSTANCE? -(defmethod handle-repaint :before ((pane goatee-text-field-pane) region) +(defmethod handle-repaint :before ((pane goatee-editor-substrate) region) (declare (ignore region)) (unless (area pane) (multiple-value-bind (cx cy) - (stream-cursor-position pane) + (stream-cursor-position pane) (setf (cursor-visibility (stream-text-cursor pane)) nil) (setf (area pane) (make-instance 'goatee:simple-screen-area - :area-stream pane - :x-position cx - :y-position cy - :initial-contents (slot-value pane - 'value)))) + :area-stream pane + :x-position cx + :y-position cy + :initial-contents (slot-value pane 'value)))) (stream-add-output-record pane (area pane))))

;;; This implements click-to-focus-keyboard-and-pass-click-through ;;; behaviour. -(defmethod handle-event :before - ((gadget goatee-text-field-pane) (event pointer-button-press-event)) +(defmethod handle-event :before + ((gadget goatee-editor-substrate) (event pointer-button-press-event)) (let ((previous (stream-set-input-focus gadget))) (when (and previous (typep previous 'gadget)) (disarmed-callback previous (gadget-client previous) (gadget-id previous))) (armed-callback gadget (gadget-client gadget) (gadget-id gadget))))

-(defmethod armed-callback :after ((gadget goatee-text-field-pane) client id) +(defmethod armed-callback :after ((gadget goatee-editor-substrate) client id) (declare (ignore client id)) (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) (setf (cursor-appearance cursor) :solid))))

-(defmethod disarmed-callback :after ((gadget goatee-text-field-pane) client id) +(defmethod disarmed-callback :after ((gadget goatee-editor-substrate) client id) (declare (ignore client id)) (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) (setf (cursor-appearance cursor) :hollow))))

-(defmethod handle-event - ((gadget goatee-text-field-pane) (event key-press-event)) +(defmethod handle-event + ((gadget goatee-editor-substrate) (event key-press-event)) (let ((gesture (convert-to-gesture event)) (*activation-gestures* (activation-gestures gadget))) (when (activation-gesture-p gesture) @@ -209,7 +224,7 @@ (gadget-id gadget) new-value)))))

-(defmethod (setf gadget-value) :after (new-value (gadget goatee-text-field-pane) +(defmethod (setf gadget-value) :after (new-value (gadget goatee-editor-substrate) &key invoke-callback) (declare (ignore invoke-callback)) (let* ((area (area gadget)) @@ -221,7 +236,7 @@ (goatee::redisplay-area area)))

#+nil -(defmethod handle-repaint ((pane goatee-text-field-pane) region) +(defmethod handle-repaint ((pane goatee-editor-substrate) region) (declare (ignore region)) (with-special-choices (pane) (with-sheet-medium (medium pane) @@ -233,8 +248,12 @@ :align-x :left :align-y :baseline)))))

+(defclass goatee-text-field-substrate (text-field-substrate-mixin + goatee-editor-substrate) + () + (:documentation "The class for Goatee-based text field substrates."))

-(defmethod compose-space ((pane goatee-text-field-pane) &key width height) +(defmethod compose-space ((pane goatee-text-field-substrate) &key width height) (declare (ignore width height)) (with-sheet-medium (medium pane) (let ((as (text-style-ascent (medium-text-style medium) medium)) @@ -243,48 +262,140 @@ (let ((width w) (height (+ as ds))) (make-space-requirement :width width :height height - :max-width width :max-height height - :min-width width :min-height height))))) + :max-width width :max-height height + :min-width width :min-height height))))) + +(defclass goatee-text-editor-substrate (text-editor-substrate-mixin + goatee-editor-substrate) + () + (:documentation "The class for Goatee-based text field substrates."))

-(defmethod allocate-space ((pane goatee-text-field-pane) w h) +(defmethod compose-space ((pane goatee-text-editor-substrate) &key width height) + (with-sheet-medium (medium pane) + (let* ((text-style (medium-text-style medium)) + (line-height (+ (text-style-height text-style medium) + (stream-vertical-spacing pane))) + (column-width (text-style-width text-style medium))) + (with-accessors ((ncolumns text-editor-ncolumns) + (nlines text-editor-nlines)) pane + (apply #'space-requirement-combine* #'(lambda (req1 req2) + (or req2 req1)) + (call-next-method) + (let ((width (if ncolumns + (+ (* ncolumns column-width)) + width)) + (height (if nlines + (+ (* nlines line-height)) + height))) + (list :width width :max-width width :min-width width + :height height :max-height height :min-height height))))))) + +(defmethod allocate-space ((pane goatee-text-editor-substrate) w h) (resize-sheet pane w h))

-(defclass goatee-text-editor-pane (goatee-text-field-pane) - ((width :type integer - :initarg :width - :initform 300 - :reader text-editor-width) - (height :type integer - :initarg :height - :initform 300 - :reader text-editor-height)) - (:default-initargs :activation-gestures nil)) - -(defmethod compose-space ((pane goatee-text-editor-pane) &key width height) - (declare (ignore width height)) - (let ((width (text-editor-width pane)) - (height (text-editor-height pane))) - (make-space-requirement :width width - :min-width width - :max-width width - :height height - :min-height height - :max-height height))) +(defun make-text-field-substrate (user &rest args) + "Create an appropriate text field gadget editing substrate object." + (let* ((substrate (apply #'make-pane (if *use-goatee* + 'goatee-text-field-substrate + 'drei-text-field-substrate) + :user-gadget user args)) + (sheet substrate)) + (values substrate sheet))) + +(defun make-text-editor-substrate (user &rest args &key scroll-bars value + &allow-other-keys) + "Create an appropriate text editor gadget editing substrate +object. Returns two values, the first is the substrate object, +the second is the sheet that should be adopted by the user +gadget." + (let* ((minibuffer (when (and (not *use-goatee*) scroll-bars) + (make-pane 'drei::drei-minibuffer-pane))) + (substrate (apply #'make-pane (if *use-goatee* + 'goatee-text-editor-substrate + 'drei-text-editor-substrate) + :user-gadget user + :minibuffer minibuffer args)) + (sheet (if scroll-bars + (scrolling (:scroll-bars scroll-bars) + substrate) + substrate))) + (if *use-goatee* + (setf (slot-value substrate 'value) value) + (setf (gadget-value substrate) value)) + (values substrate (if minibuffer + (vertically ()

[90 lines skipped] --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/03/04 22:27:30 1.106 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/08/21 22:09:01 1.107 @@ -644,6 +644,11 @@ (:documentation "The value is a string") (:default-initargs :value ""))

+(defmethod initialize-instance :after ((gadget text-field) &rest rest) + (unless (getf rest :normal) + (setf (slot-value gadget 'current-color) +white+ + (slot-value gadget 'normal) +white+))) + ;;; 30.4.9 The abstract text-editor Gadget

(defclass text-editor (text-field)