Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv24255/Drei
Modified Files: core.lisp drei-clim.lisp drei-redisplay.lisp drei.lisp lisp-syntax.lisp lr-syntax.lisp packages.lisp syntax.lisp views.lisp Log Message: Make Drei support nonstandard views somewhat.
--- /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/12/08 23:25:23 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/12/10 21:25:12 1.10 @@ -325,16 +325,16 @@ specified syntax. `syntax' may be a string containing the name of a known syntax."))
-(defmethod set-syntax ((view textual-drei-syntax-view) (syntax syntax)) +(defmethod set-syntax ((view drei-syntax-view) (syntax syntax)) (setf (syntax view) syntax))
-(defmethod set-syntax ((view textual-drei-syntax-view) (syntax symbol)) +(defmethod set-syntax ((view drei-syntax-view) (syntax symbol)) (set-syntax view (make-syntax-for-view view syntax)))
-(defmethod set-syntax ((view textual-drei-syntax-view) (syntax class)) +(defmethod set-syntax ((view drei-syntax-view) (syntax class)) (set-syntax view (make-syntax-for-view view syntax)))
-(defmethod set-syntax ((view textual-drei-syntax-view) (syntax string)) +(defmethod set-syntax ((view drei-syntax-view) (syntax string)) (let ((syntax-class (syntax-from-name syntax))) (cond (syntax-class (set-syntax view (make-syntax-for-view view syntax-class))) --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/12/08 08:53:50 1.23 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/12/10 21:25:12 1.24 @@ -400,12 +400,13 @@ (syntax nil) (initial-contents "") (minibuffer t) (border-width 1) (scroll-bars :horizontal) - (drei-class 'drei-gadget-pane)) + (drei-class 'drei-gadget-pane) + (view 'textual-drei-syntax-view)) (check-type initial-contents array) (check-type border-width integer) (check-type scroll-bars (member t :both :vertical :horizontal nil)) (with-keywords-removed (args (:minibuffer :scroll-bars :border-width - :syntax :drei-class)) + :syntax :drei-class :view)) (let* ((borderp (and border-width (plusp border-width))) (minibuffer-pane (cond ((eq minibuffer t) (make-pane 'drei-minibuffer-pane)) @@ -416,11 +417,13 @@ (t (error "Provided minibuffer is not T, NIL or a `minibuffer-pane'.")))) (drei-pane (apply #'make-pane-1 fm frame drei-class - :minibuffer minibuffer-pane args)) + :minibuffer minibuffer-pane + :view (make-instance view) + args)) (pane drei-pane) (view (view drei-pane))) (letf (((read-only-p (buffer view)) nil)) - (insert-sequence (point view) initial-contents)) + (insert-buffer-sequence (buffer view) 0 initial-contents)) (if syntax (setf (syntax view) (make-instance (or (when (syntaxp syntax) --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/12/10 05:25:19 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/12/10 21:25:12 1.12 @@ -103,17 +103,17 @@ (letf (((stream-default-view stream) view)) (call-next-method)))))
-(defmethod display-drei-view-cursor ((stream extended-output-stream) (view textual-drei-syntax-view) +(defmethod display-drei-view-cursor ((stream extended-output-stream) + (view drei-view) (cursor drei-cursor)) - (let ((mark (mark cursor))) - (multiple-value-bind (cursor-x cursor-y line-height) - (offset-to-screen-position stream view (offset mark)) - (updating-output (stream :unique-id (list stream :cursor) - :cache-value (list* cursor-x cursor-y line-height)) - (draw-rectangle* stream - (1- cursor-x) cursor-y - (+ cursor-x 2) (+ cursor-y line-height) - :ink (ink cursor)))))) + (multiple-value-bind (cursor-x cursor-y line-height) + (offset-to-screen-position stream view (offset (mark cursor))) + (updating-output (stream :unique-id (list stream :cursor) + :cache-value (list* cursor-x cursor-y line-height)) + (draw-rectangle* stream + (1- cursor-x) cursor-y + (+ cursor-x 2) (+ cursor-y line-height) + :ink (ink cursor)))))
(defmethod display-drei-view-cursor :after ((stream extended-output-stream) (view drei-view) (cursor point-cursor)) @@ -431,14 +431,15 @@ (setf (offset (point view)) (offset bot)) (beginning-of-line (point view))))))
-(defgeneric fix-pane-viewport (pane)) +(defgeneric fix-pane-viewport (pane view) + (:documentation "Fix the size and scrolling of `pane', which +has `view'."))
-(defmethod fix-pane-viewport ((pane drei-pane)) +(defmethod fix-pane-viewport ((pane drei-pane) (view drei-view)) (let* ((output-width (bounding-rectangle-width (stream-current-output-record pane))) (viewport (pane-viewport pane)) (viewport-width (and viewport (bounding-rectangle-width viewport))) - (pane-width (bounding-rectangle-width pane)) - (view (view pane))) + (pane-width (bounding-rectangle-width pane))) ;; If the width of the output is greater than the width of the ;; sheet, make the sheet wider. If the sheet is wider than the ;; viewport, but doesn't really need to be, make it thinner. @@ -446,42 +447,53 @@ (and viewport (> pane-width viewport-width) (>= viewport-width output-width))) - (change-space-requirements pane :width output-width)) - (when (and viewport (active pane)) - (multiple-value-bind (cursor-x cursor-y) (offset-to-screen-position pane view (offset (point view))) - (declare (ignore cursor-y)) - (let ((x-position (abs (transform-position (sheet-transformation pane) 0 0))) - (viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane)))) - (cond ((> cursor-x (+ x-position viewport-width)) - (move-sheet pane (round (- (- cursor-x viewport-width))) 0)) - ((> x-position cursor-x) - (move-sheet pane (if (> viewport-width cursor-x) - 0 - (round (- cursor-x))) - 0)))))))) + (change-space-requirements pane :width output-width)))) + +(defmethod fix-pane-viewport :after ((pane drei-pane) (view point-mark-view)) + (when (and (pane-viewport pane) (active pane)) + (multiple-value-bind (cursor-x cursor-y) (offset-to-screen-position pane view (offset (point view))) + (declare (ignore cursor-y)) + (let ((x-position (abs (transform-position (sheet-transformation pane) 0 0))) + (viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane)))) + (cond ((> cursor-x (+ x-position viewport-width)) + (move-sheet pane (round (- (- cursor-x viewport-width))) 0)) + ((> x-position cursor-x) + (move-sheet pane (if (> viewport-width cursor-x) + 0 + (round (- cursor-x))) + 0)))))))
(defmethod handle-repaint :before ((pane drei-pane) region) (declare (ignore region)) (redisplay-frame-pane (pane-frame pane) pane))
+(defgeneric fully-redisplay-pane (pane view) + (:documentation "Fully redisplay `pane' showing `view', finally +setting the `full-redisplay-p' flag to false.") + (:method :after (pane (view drei-view)) + (setf (full-redisplay-p view) nil))) + +(defmethod fully-redisplay-pane ((drei-pane drei-pane) + (view point-mark-view)) + (reposition-pane drei-pane) + (adjust-pane-bot drei-pane) + (setf (full-redisplay-p view) nil)) + (defun display-drei-pane (frame drei-pane) "Display `pane'. If `pane' has focus, `current-p' should be non-NIL." (declare (ignore frame)) (let ((view (view drei-pane))) - (with-accessors ((buffer buffer) (top top) (bot bot)) (view drei-pane) - (if (full-redisplay-p view) - (progn (reposition-pane drei-pane) - (adjust-pane-bot drei-pane) - (setf (full-redisplay-p view) nil)) - (adjust-pane drei-pane)) - #+nil(update-syntax-for-display buffer syntax top bot) + (with-accessors ((buffer buffer) (top top) (bot bot)) view + (when (typep view 'point-mark-view) + (if (full-redisplay-p view) + (fully-redisplay-pane drei-pane view) + (adjust-pane drei-pane))) (display-drei-view-contents drei-pane view) ;; Point must be on top of all other cursors. - (display-drei-view-cursor drei-pane view (point-cursor drei-pane)) (dolist (cursor (cursors drei-pane)) (display-drei-view-cursor drei-pane view cursor)) - (fix-pane-viewport drei-pane)))) + (fix-pane-viewport drei-pane (view drei-pane)))))
(defgeneric full-redisplay (pane) (:documentation "Queue a full redisplay for `pane'.")) --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/08 08:53:50 1.20 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/10 21:25:12 1.21 @@ -210,11 +210,10 @@ (additional-command-tables *drei-instance* command-table))
(defmethod command-table-inherit-from ((table drei-command-table)) - (let ((syntax-table (command-table (current-syntax)))) - (append `(,syntax-table) - (additional-command-tables *drei-instance* table) - (when (use-editor-commands-p syntax-table) - '(editor-table))))) + (append (view-command-tables (current-view)) + (additional-command-tables *drei-instance* table) + (when (use-editor-commands-p (current-view)) + '(editor-table))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/08 08:53:50 1.33 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/10 21:25:12 1.34 @@ -116,12 +116,16 @@
(defmethod name-for-info-pane ((syntax lisp-syntax) &key view) (format nil "Lisp~@[:~(~A~)~]" - (provided-package-name-at-mark syntax (point view)))) + (provided-package-name-at-mark syntax (if (typep view 'point-mark-view) + (point view) + 0))))
(defmethod display-syntax-name ((syntax lisp-syntax) (stream extended-output-stream) &key view) (princ "Lisp:" stream) ; FIXME: should be `present'ed ; as something. - (let ((package-name (provided-package-name-at-mark syntax (point view)))) + (let ((package-name (provided-package-name-at-mark syntax (if (typep view 'point-mark-view) + (point view) + 0)))) (if (find-package package-name) (with-output-as-presentation (stream (find-package package-name) 'expression) (princ package-name stream)) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2007/12/08 08:53:50 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2007/12/10 21:25:12 1.4 @@ -39,8 +39,7 @@ (defmethod initialize-instance :after ((syntax lr-syntax-mixin) &rest args) (declare (ignore args)) (with-accessors ((buffer buffer) (scan scan)) syntax - (setf scan (make-buffer-mark buffer 0 :left)) - (update-syntax syntax 0 0))) + (setf scan (make-buffer-mark buffer 0 :left))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/08 23:25:23 1.20 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/10 21:25:12 1.21 @@ -138,7 +138,7 @@ (defpackage :drei-syntax (:use :clim-lisp :clim :drei-buffer :drei-base :flexichain :esa-utils) (:export #:syntax #:update-parse #:syntaxp #:define-syntax #:*default-syntax* #:cursor-positions - #:syntax-command-table #:use-editor-commands-p #:additional-command-tables #:define-syntax-command-table + #:syntax-command-table #:additional-command-tables #:define-syntax-command-table #:eval-option #:define-option-for-syntax #:current-attributes-for-syntax @@ -210,6 +210,7 @@ #:drei-view #:modified-p #:no-cursors #:drei-buffer-view #:buffer #:top #:bot #:drei-syntax-view #:syntax + #:point-mark-view #:textual-drei-syntax-view #:tab-space-count #:space-width #:tab-width #:auto-fill-mode #:auto-fill-column @@ -221,7 +222,10 @@ #:prefix-start-offset #:overwrite-mode #:goal-column - + + #:view-command-tables + #:use-editor-commands-p + #:synchronize-view #:create-view-cursors #:clone-view #:make-syntax-for-view --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2007/12/08 08:53:49 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2007/12/10 21:25:12 1.8 @@ -88,20 +88,6 @@ available when Lisp syntax is used in Climacs (or another editor), but not anywhere else."))
-(defgeneric use-editor-commands-p (command-table) - (:documentation "If `command-table' is supposed to include -standard editor commands (for inserting objects, moving cursor, -etc), this function will return T (the default). If you want your -syntax to use standard editor commands, you should *not* inherit -from `editor-table' - the command tables containing the editor -commands will be added automatically, as long as this function -returns true. For most syntax command tables, you do not need to -define a method for this generic function, you really do want the -standard editor commands for all but the most esoteric -syntaxes.") - (:method ((command-table standard-command-table)) - t)) - (defgeneric additional-command-tables (editor command-table) (:method-combination append) (:documentation "Return a list of additional command tables --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/10 05:27:46 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/10 21:25:12 1.3 @@ -142,7 +142,7 @@ buffer contents at a specific offset."))
(defclass insert-record (simple-undo-record) - ((objects :initarg :objects + ((objects :initarg :objects :documentation "The sequence of objects that are to be inserted whenever flip-undo-record is called on an instance of insert-record.")) @@ -421,7 +421,21 @@ :initarg :no-cursors :initform nil :documentation "True if the view does not display -cursors.")) +cursors.") + (%full-redisplay-p :accessor full-redisplay-p + :initform nil + :documentation "True if the view should be +fully redisplayed the next time it is redisplayed.") + (%use-editor-commands :accessor use-editor-commands-p + :initarg :use-editor-commands + :initform nil + :documentation "If the view is supposed +to support standard editor commands (for inserting objects, +moving cursor, etc), this will be true. If you want your view to +support standard editor commands, you should *not* inherit from +`editor-table' - the command tables containing the editor +commands will be added automatically, as long as this value is +true.")) (:documentation "The base class for all Drei views. A view observes some other object and provides a visual representation for Drei.") @@ -433,6 +447,13 @@ arguments are supported, is up to the individual view subclass."))
+(defgeneric view-command-tables (view) + (:documentation "Return a list of command tables containing +commands relevant for `view'.") + (:method-combination append) + (:method append ((view drei-view)) + '())) + (defgeneric create-view-cursors (output-stream view) (:documentation "Create cursors for `view' that are to be displayed on `output-stream'.") @@ -464,8 +485,9 @@ nconc (list slot-initarg (slot-value view slot-name)))))))
(defclass drei-buffer-view (drei-view) - ((%buffer :initform (make-instance 'drei-buffer) - :initarg :buffer :accessor buffer + ((%buffer :accessor buffer + :initform (make-instance 'drei-buffer) + :initarg :buffer :type drei-buffer :accessor buffer) (%top :accessor top @@ -557,6 +579,11 @@ suffix-size) (modified-p view) t)))
+(defmethod synchronize-view :around ((view drei-syntax-view) &key) + ;; If nothing changed, then don't call the other methods. + (unless (= (prefix-size view) (suffix-size view) (size (buffer view))) + (call-next-method))) + (defmethod synchronize-view ((view drei-syntax-view) &key (begin 0) (end (size (buffer view)))) "Synchronize the syntax view with the underlying @@ -565,13 +592,12 @@ size of the buffer respectively." (let ((prefix-size (prefix-size view)) (suffix-size (suffix-size view))) - (unless (= prefix-size suffix-size (size (buffer view))) - ;; Reset here so if `update-syntax' calls `update-parse' itself, - ;; we won't end with infinite recursion. - (setf (prefix-size view) (size (buffer view)) - (suffix-size view) (size (buffer view))) - (update-syntax (syntax view) prefix-size suffix-size - begin end)))) + ;; Reset here so if `update-syntax' calls `update-parse' itself, + ;; we won't end with infinite recursion. + (setf (prefix-size view) (size (buffer view)) + (suffix-size view) (size (buffer view))) + (update-syntax (syntax view) prefix-size suffix-size + begin end)))
(defun make-syntax-for-view (view syntax-symbol &rest args) (apply #'make-instance syntax-symbol @@ -580,28 +606,13 @@ (synchronize-view view :begin begin :end end))) args))
-(defclass textual-drei-syntax-view (drei-syntax-view textual-view) +(defclass point-mark-view (drei-buffer-view) ((%point :initform nil :initarg :point :accessor point-of) - (%mark :initform nil :initarg :mark :accessor mark-of) - (%auto-fill-mode :initform nil :accessor auto-fill-mode) - (%auto-fill-column :initform 70 :accessor auto-fill-column) - (%region-visible-p :initform nil :accessor region-visible-p) - (%full-redisplay-p :initform nil :accessor full-redisplay-p) - ;; for next-line and previous-line commands - (%goal-column :initform nil :accessor goal-column) - ;; for dynamic abbrev expansion - (%original-prefix :initform nil :accessor original-prefix) - (%prefix-start-offset :initform nil :accessor prefix-start-offset) - (%dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark) - (%overwrite-mode :initform nil :accessor overwrite-mode) - (%point-cursor :accessor point-cursor - :initarg :point-cursor - :type drei-cursor - :documentation "The cursor object associated -with point. This is guaranteed to be displayed -on top of all other cursors."))) + (%mark :initform nil :initarg :mark :accessor mark-of)) + (:documentation "A view class containing a point and a mark +into its buffer."))
-(defmethod initialize-instance :after ((view textual-drei-syntax-view) +(defmethod initialize-instance :after ((view point-mark-view) &rest args) (declare (ignore args)) (with-accessors ((point point) (mark mark) @@ -609,19 +620,38 @@ (setf point (clone-mark (point buffer))) (setf mark (clone-mark (point buffer)))))
-(defmethod (setf buffer) :before ((buffer drei-buffer) (view textual-drei-syntax-view)) +(defmethod (setf buffer) :before ((buffer drei-buffer) (view point-mark-view)) ;; Set the point of the old buffer to the current point of the view, ;; so the next time the buffer is revealed, it will remember its ;; point. (setf (point (buffer view)) (point view)))
-(defmethod (setf buffer) :after ((buffer drei-buffer) (view textual-drei-syntax-view)) +(defmethod (setf buffer) :after ((buffer drei-buffer) (view point-mark-view)) (with-accessors ((point point) (mark mark)) view (setf point (clone-mark (point buffer)) mark (clone-mark (point buffer) :right))))
+(defclass textual-drei-syntax-view (drei-syntax-view point-mark-view textual-view) + ((%auto-fill-mode :initform nil :accessor auto-fill-mode) + (%auto-fill-column :initform 70 :accessor auto-fill-column) + (%region-visible-p :initform nil :accessor region-visible-p) + ;; for next-line and previous-line commands + (%goal-column :initform nil :accessor goal-column) + ;; for dynamic abbrev expansion + (%original-prefix :initform nil :accessor original-prefix) + (%prefix-start-offset :initform nil :accessor prefix-start-offset) + (%dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark) + (%overwrite-mode :initform nil :accessor overwrite-mode)) + (:default-initargs :use-editor-commands t)) + (defmethod create-view-cursors nconc ((output-stream extended-output-stream) (view textual-drei-syntax-view)) (unless (no-cursors view) - (list (make-instance 'mark-cursor :view view :output-stream output-stream) - (make-instance 'point-cursor :view view :output-stream output-stream)))) + (list (make-instance 'point-cursor :view view :output-stream output-stream) + (make-instance 'mark-cursor :view view :output-stream output-stream)))) + +(defmethod view-command-tables append ((view textual-drei-syntax-view)) + (list (command-table (syntax view)))) + +(defmethod use-editor-commands-p ((view textual-drei-syntax-view)) + t)