[mcclim-cvs] CVS mcclim/Drei
thenriksen
thenriksen at common-lisp.net
Mon Dec 10 21:25:13 UTC 2007
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)
More information about the Mcclim-cvs
mailing list