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 ,@args)))) - #'(lambda (view parser-symbol) - (declare (ignore view parser-symbol)) - options))) - (:options `#'(lambda (view parser-symbol) - (declare (ignore view parser-symbol)) - (make-drawing-options ,@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 ,@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 ,@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))))))