[mcclim-cvs] CVS mcclim
thenriksen
thenriksen at common-lisp.net
Tue Aug 21 22:09:02 UTC 2007
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)
More information about the Mcclim-cvs
mailing list