[mcclim-cvs] CVS mcclim/Drei
thenriksen
thenriksen at common-lisp.net
Sun Feb 10 00:42:03 UTC 2008
Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv32363/Drei
Modified Files:
lisp-syntax.lisp lr-syntax.lisp
Log Message:
Added notion of "sticky" highlighting rules to LR syntax.
Used this to add syntax highlighting for reader conditionals in Lisp syntax.
Has instant gratification - faster than SLIME! (Ok, we cheat, and can
just look at the running Lisp, but anyway.)
--- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/31 18:44:36 1.73
+++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/02/10 00:42:03 1.74
@@ -994,7 +994,8 @@
;;;;;;;;;;;;;;;; Reader conditionals
;;; parse trees
-(defclass reader-conditional-form (form) ())
+(defclass reader-conditional-form (form)
+ ((%conditional-true-p :accessor conditional-true-p)))
(defclass reader-conditional-positive-form (reader-conditional-form) ())
(defclass reader-conditional-negative-form (reader-conditional-form) ())
@@ -1833,6 +1834,20 @@
(progn (cache-symbol-info syntax symbol-form)
(global-boundp symbol-form))))
+(defun cache-conditional-info (syntax form)
+ "Cache information about the reader conditional `symbol-form' represents,
+so that it can be quickly looked up later."
+ (setf (conditional-true-p form)
+ (eval-feature-conditional (second-noncomment (children form)) syntax)))
+
+(defun reader-conditional-true (syntax form)
+ "Return true if the reader conditional `form' has a true
+condition."
+ (if (slot-boundp form '%conditional-true-p)
+ (conditional-true-p form)
+ (progn (cache-conditional-info syntax form)
+ (conditional-true-p form))))
+
(defun parenthesis-highlighter (view form)
"Return the drawing style with which the parenthesis lexeme
`form' should be highlighted."
@@ -1844,6 +1859,23 @@
+bold-face-drawing-options+
+default-drawing-options+))
+(defun reader-conditional-rule-fn (positive comment-options)
+ "Return a function for use as a syntax highlighting
+rule-generator for reader conditionals. If `positive', the
+function will be for positive
+reader-conditionals. `Comment-options' is the drawing options
+object that will be returned when the conditional is not
+fulfilled."
+ (if positive
+ #'(lambda (view form)
+ (if (reader-conditional-true (syntax view) form)
+ +default-drawing-options+
+ (values comment-options t)))
+ #'(lambda (view form)
+ (if (not (reader-conditional-true (syntax view) form))
+ +default-drawing-options+
+ (values comment-options t)))))
+
(define-syntax-highlighting-rules emacs-style-highlighting
(error-lexeme (*error-drawing-options*))
(string-form (*string-drawing-options*))
@@ -1857,18 +1889,29 @@
((symbol-form-is-boundp (syntax view) form)
*special-variable-drawing-options*)
(t +default-drawing-options+)))))
- (parenthesis-lexeme (:function #'parenthesis-highlighter)))
+ (parenthesis-lexeme (:function #'parenthesis-highlighter))
+ (reader-conditional-positive-form
+ (:function (reader-conditional-rule-fn t *comment-drawing-options*)))
+ (reader-conditional-negative-form
+ (:function (reader-conditional-rule-fn nil *comment-drawing-options*))))
+
+(defvar *retro-comment-drawing-options*
+ (make-drawing-options :face (make-face :ink +dimgray+))
+ "The drawing options used for retro-highlighting in Lisp syntax.")
(define-syntax-highlighting-rules retro-highlighting
(error-symbol (*error-drawing-options*))
(string-form (:options :face +italic-face+))
- (comment (:face :ink +dimgray+))
+ (comment (*retro-comment-drawing-options*))
(literal-object-form (:options :function (object-drawer)))
(complete-token-form (:function #'(lambda (syntax form)
(cond ((symbol-form-is-macrobound-p syntax form)
+bold-face-drawing-options+)
(t +default-drawing-options+)))))
- ;; XXX: Ugh, copied from above.
+ (reader-conditional-positive-form
+ (:function (reader-conditional-rule-fn t *retro-comment-drawing-options*)))
+ (reader-conditional-negative-form
+ (:function (reader-conditional-rule-fn nil *retro-comment-drawing-options*)))
(parenthesis-lexeme (:function #'parenthesis-highlighter)))
(defparameter *syntax-highlighting-rules* 'emacs-style-highlighting
--- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/09 11:14:08 1.16
+++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/02/10 00:42:03 1.17
@@ -443,7 +443,18 @@
Alternatively, `type' can be any object (usually a dynamically
bound symbol), in which case it will be evaluated to get the
-drawing options."
+drawing options.
+
+`Type' can also be a list, in which case the first element will
+be interpreted as described above, and the remaining elements
+will be considered keyword arguments. The following keyword
+arguments are supported:
+
+ `:sticky': if true, the syntax highlighting options defined by
+ this rule will apply to all children as well, effectively
+ overriding their options. The default is false. For a
+ `:function', `:sticky' will not work. Instead, return a true
+ secondary value from the function."
(check-type name symbol)
`(progn
(fmakunbound ',name)
@@ -451,18 +462,20 @@
(:method (view (parser-symbol parser-symbol))
nil))
,@(flet ((make-rule-exp (type args)
- (case type
- (:face `(let ((options (make-drawing-options :face (make-face , at args))))
- #'(lambda (view parser-symbol)
- (declare (ignore view parser-symbol))
- options)))
- (:options `#'(lambda (view parser-symbol)
- (declare (ignore view parser-symbol))
- (make-drawing-options , at args)))
- (:function (first args))
- (t `#'(lambda (view parser-symbol)
- (declare (ignore view parser-symbol))
- ,type)))))
+ (let ((actual-type (first (listed type))))
+ (destructuring-bind (&key sticky) (rest (listed type))
+ (case actual-type
+ (:face `(let ((options (make-drawing-options :face (make-face , at args))))
+ #'(lambda (view parser-symbol)
+ (declare (ignore view parser-symbol))
+ (values options ,sticky))))
+ (:options `#'(lambda (view parser-symbol)
+ (declare (ignore view parser-symbol))
+ (values (make-drawing-options , at args) ,sticky)))
+ (:function (first args))
+ (t `#'(lambda (view parser-symbol)
+ (declare (ignore view parser-symbol))
+ (values ,actual-type ,sticky))))))))
(loop for (parser-symbol (type . args)) in rules
collect `(let ((rule ,(make-rule-exp type args)))
(defmethod ,name (view (parser-symbol ,parser-symbol))
@@ -499,6 +512,18 @@
parser-symbol offset
drawing-options highlighting-rules)
+(defstruct (drawing-options-frame
+ (:constructor make-drawing-options-frame
+ (end-offset drawing-options sticky-p))
+ (:conc-name frame-))
+ "An entry in the drawing options stack maintained by the
+`pump-state' structure. `End-offset' is the end buffer offset
+for the frame, `drawing-options' is the drawing options that
+should be used until that offset, and if `sticky-p' is true it
+will not be possible to put other frames on top of this one in
+the stack."
+ end-offset drawing-options sticky-p)
+
(defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view)
(syntax lr-syntax-mixin) (offset integer))
(update-parse syntax 0 (size (buffer view)))
@@ -506,15 +531,18 @@
(highlighting-rules (syntax-highlighting-rules syntax)))
(labels ((initial-drawing-options (parser-symbol)
(if (null parser-symbol)
- (cons (size (buffer view)) +default-drawing-options+)
- (let ((drawing-options
- (get-drawing-options highlighting-rules view parser-symbol)))
+ (make-drawing-options-frame
+ (size (buffer view)) +default-drawing-options+ nil)
+ (multiple-value-bind (drawing-options sticky)
+ (get-drawing-options highlighting-rules view parser-symbol)
(if (null drawing-options)
(initial-drawing-options (parent parser-symbol))
- (cons (end-offset parser-symbol) drawing-options))))))
+ (make-drawing-options-frame (end-offset parser-symbol)
+ drawing-options sticky))))))
(make-pump-state parser-symbol offset
(list (initial-drawing-options parser-symbol)
- (cons (1+ (size (buffer view))) +default-drawing-options+))
+ (make-drawing-options-frame
+ (1+ (size (buffer view))) +default-drawing-options+ nil))
highlighting-rules))))
(defun find-next-stroke-end (view pump-state)
@@ -527,15 +555,16 @@
(highlighting-rules pump-state-highlighting-rules))
pump-state
(let ((line (line-containing-offset (syntax view) offset)))
- (flet ((finish (offset symbol &optional stroke-drawing-options)
+ (flet ((finish (new-offset symbol &optional stroke-drawing-options sticky-p)
(setf start-symbol symbol)
- (loop until (> (car (first drawing-options)) offset)
- do (pop drawing-options))
(unless (null stroke-drawing-options)
- (push (cons (end-offset symbol) stroke-drawing-options)
+ (push (if (frame-sticky-p (first drawing-options))
+ (make-drawing-options-frame
+ (end-offset symbol) (frame-drawing-options (first drawing-options)) t)
+ (make-drawing-options-frame
+ (end-offset symbol) stroke-drawing-options sticky-p))
drawing-options))
- (return-from find-next-stroke-end
- offset)))
+ (return-from find-next-stroke-end new-offset)))
(cond ((null start-symbol)
;; This means that all remaining lines are blank.
(finish (line-end-offset line) nil))
@@ -543,28 +572,38 @@
(= offset (start-offset start-symbol)))
(finish (end-offset start-symbol) start-symbol nil))
(t
- (or (do-parse-symbols-forward (symbol offset start-symbol)
- (let ((symbol-drawing-options
- (get-drawing-options highlighting-rules view symbol)))
- (cond ((> (start-offset symbol) (line-end-offset line))
- (finish (line-end-offset line) start-symbol))
- ((and (typep symbol 'literal-object-mixin))
- (finish (start-offset symbol) symbol
- (or symbol-drawing-options
- (make-drawing-options :function (object-drawer)))))
- ((and (> (start-offset symbol) offset)
- (not (drawing-options-equal (or symbol-drawing-options
- +default-drawing-options+)
- (cdr (first drawing-options))))
- (if (null symbol-drawing-options)
- (>= (start-offset symbol) (car (first drawing-options)))
- t))
- (finish (start-offset symbol) symbol symbol-drawing-options))
- ((and (= (start-offset symbol) offset)
- symbol-drawing-options
- (not (drawing-options-equal symbol-drawing-options
- (cdr (first drawing-options)))))
- (finish (start-offset symbol) symbol symbol-drawing-options)))))
+ (or (let* ((current-frame (first drawing-options))
+ (currently-used-options (frame-drawing-options current-frame)))
+ (do-parse-symbols-forward (symbol offset start-symbol)
+ (multiple-value-bind (symbol-drawing-options sticky)
+ (get-drawing-options highlighting-rules view symbol)
+ ;; Remove frames that are no longer applicable...
+ (loop until (> (frame-end-offset (first drawing-options))
+ (start-offset symbol))
+ do (pop drawing-options))
+ (let ((options-to-be-used (if (frame-sticky-p (first drawing-options))
+ (frame-drawing-options (first drawing-options))
+ symbol-drawing-options)))
+ (cond ((> (start-offset symbol) (line-end-offset line))
+ (finish (line-end-offset line) start-symbol))
+ ((and (typep symbol 'literal-object-mixin))
+ (finish (start-offset symbol) symbol
+ (or symbol-drawing-options
+ (make-drawing-options :function (object-drawer)))))
+ ((and (> (start-offset symbol) offset)
+ (not (drawing-options-equal (or options-to-be-used
+ +default-drawing-options+)
+ currently-used-options))
+ (if (null symbol-drawing-options)
+ (>= (start-offset symbol) (frame-end-offset current-frame))
+ t))
+ (finish (start-offset symbol) symbol symbol-drawing-options sticky))
+ ((and (= (start-offset symbol) offset)
+ symbol-drawing-options
+ (not (drawing-options-equal
+ options-to-be-used
+ (frame-drawing-options (first drawing-options)))))
+ (finish (start-offset symbol) symbol symbol-drawing-options sticky)))))))
;; If there are no more parse symbols, we just go
;; line-by-line from here. This should mean that all
;; remaining lines are blank.
@@ -578,11 +617,15 @@
(with-accessors ((offset pump-state-offset)
(current-drawing-options pump-state-drawing-options))
pump-state
- (let ((old-drawing-options (cdr (first current-drawing-options)))
- (end-offset (find-next-stroke-end view pump-state)))
+ (let ((old-drawing-options (frame-drawing-options (first current-drawing-options)))
+ (end-offset (find-next-stroke-end view pump-state))
+ (old-offset offset))
(setf (stroke-start-offset stroke) offset
(stroke-end-offset stroke) end-offset
(stroke-drawing-options stroke) old-drawing-options
offset (if (offset-end-of-line-p (buffer view) end-offset)
(1+ end-offset)
- end-offset))))))
+ end-offset))
+ ;; Don't use empty strokes, try again...
+ (when (= old-offset offset)
+ (stroke-pump-with-syntax view syntax stroke pump-state))))))
More information about the Mcclim-cvs
mailing list