Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3433/Drei

Modified Files: fundamental-syntax.lisp lisp-syntax.lisp lr-syntax.lisp packages.lisp Log Message: Added syntax highlighting of Lisp syntax. Yay!

Doesn't highlight fully as much as it used to, as it's slightly more complicated to get fast enough.

Also, not terribly heavily optimized.

--- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/02 14:43:40 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/03 12:32:08 1.9 @@ -54,11 +54,17 @@ (defclass line-object () ((%start-mark :reader start-mark :initarg :start-mark) + (%line-length :reader line-length + :initarg :line-length) (%chunks :accessor chunks :initform (make-array 5 :adjustable t :fill-pointer 0))))

+(defun line-end-offset (line) + "Return the end buffer offset of `line'." + (+ (offset (start-mark line)) (line-length line))) + (defun get-chunk (buffer chunk-start-offset line-end-offset) (let* ((chunk-end-offset (buffer-find-nonchar buffer chunk-start-offset @@ -116,14 +122,16 @@ (setf (offset scan) (offset low-mark)) (loop while (mark<= scan high-mark) for i from low-index - do (progn (insert* lines i (make-instance - 'line-object - :start-mark (clone-mark scan))) - (end-of-line scan) - (if (end-of-buffer-p scan) - (loop-finish) - ;; skip newline - (forward-object scan))))))))) + do (progn (let ((line-start-mark (clone-mark scan))) + (insert* lines i (make-instance + 'line-object + :start-mark line-start-mark + :line-length (- (offset (end-of-line scan)) + (offset line-start-mark)))) + (if (end-of-buffer-p scan) + (loop-finish) + ;; skip newline + (forward-object scan)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -195,7 +203,32 @@

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; exploit the parse +;;; exploit the parse + +(defun offset-in-line-p (line offset) + "Return true if `offset' is in the buffer region delimited by +`line'." + (<= (offset (start-mark line)) offset + (line-end-offset line))) + +(defun line-containing-offset (syntax mark-or-offset) + "Return the line `mark-or-offset' is in for `syntax'. `Syntax' +must be a `fundamental-syntax' object." + ;; Perform binary search looking for line containing `offset1'. + (as-offsets ((offset mark-or-offset)) + (with-accessors ((lines lines)) syntax + (loop with low-index = 0 + with high-index = (nb-elements lines) + for middle = (floor (+ low-index high-index) 2) + for this-line = (element* lines middle) + for line-start = (start-mark this-line) + do (cond ((offset-in-line-p this-line offset) + (loop-finish)) + ((mark> offset line-start) + (setf low-index (1+ middle))) + ((mark< offset line-start) + (setf high-index middle))) + finally (return this-line)))))

;; do this better (defmethod syntax-line-indentation ((syntax fundamental-syntax) mark tab-width) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/02 14:21:06 1.44 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/03 12:32:08 1.45 @@ -147,6 +147,9 @@ (or (image syntax) (default-image))))

+(defconstant +keyword-package+ (find-package :keyword) + "The KEYWORD package.") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Swank interface functions. @@ -1479,6 +1482,39 @@ (or (typep (parent form) 'form*) (null (parent form)))))

+(defgeneric eval-feature-conditional (conditional-form syntax)) + +(defmethod eval-feature-conditional (conditional-form (syntax lisp-syntax)) + nil) + +;; Adapted from slime.el + +(defmethod eval-feature-conditional ((conditional token-mixin) (syntax lisp-syntax)) + (let* ((string (form-string syntax conditional)) + (symbol (parse-symbol string :package +keyword-package+))) + (member symbol *features*))) + +(defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax)) + (let ((children (children conditional))) + (when (third-noncomment children) + (flet ((eval-fc (conditional) + (funcall #'eval-feature-conditional conditional syntax))) + (let* ((type (second-noncomment children)) + (conditionals (butlast + (nthcdr + 2 + (remove-if + #'comment-p + children)))) + (type-string (form-string syntax type)) + (type-symbol (parse-symbol type-string :package +keyword-package+))) + (case type-symbol + (:and (funcall #'every #'eval-fc conditionals)) + (:or (funcall #'some #'eval-fc conditionals)) + (:not (when conditionals + (funcall #'(lambda (f l) (not (apply f l))) + #'eval-fc conditionals))))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Asking about parse state at some point @@ -1731,242 +1767,22 @@ ;;; ;;; display

-(defparameter *reader-conditional-faces* - (list (make-face :error +red+) - (make-face :string +gray50+ (make-text-style nil :italic nil)) - (make-face :keyword +gray50+) - (make-face :macro +gray50+) - (make-face :special-form +gray50+) - (make-face :lambda-list-keyword +gray50+) - (make-face :comment +gray50+) - (make-face :reader-conditional +gray50+))) - -(define-standard-faces lisp-syntax - (make-face :error +red+) - (make-face :string +rosy-brown+ (make-text-style nil :italic nil)) - (make-face :keyword +orchid+) - (make-face :macro +purple+) - (make-face :special-form +purple+) - (make-face :lambda-list-keyword +dark-green+) - (make-face :comment +maroon+) - (make-face :reader-conditional +gray50+)) - -(defmethod display-parse-tree ((parse-symbol (eql nil)) stream (view textual-drei-syntax-view) - (syntax lisp-syntax)) - nil) - -(defmethod display-parse-tree ((parse-symbol error-symbol) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((children (children parse-symbol))) - (loop until (or (null (cdr children)) - (typep (parser-state (cadr children)) 'error-state)) - do (display-parse-tree (pop children) stream view syntax)) - (if (and (null (cdr children)) - (not (typep (parser-state parse-symbol) 'error-state))) - (display-parse-tree (car children) stream view syntax) - (with-face (:error) - (loop for child in children - do (display-parse-tree child stream view syntax)))))) - -(defmethod display-parse-tree ((parse-symbol error-lexeme) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (with-face (:error) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol unmatched-right-parenthesis-lexeme) - stream (view textual-drei-syntax-view) (syntax lisp-syntax)) - (with-face (:error) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol token-mixin) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (if (> (the fixnum (end-offset parse-symbol)) (the fixnum (start-offset parse-symbol))) - (let ((symbol (form-to-object syntax parse-symbol :no-error t))) - (with-output-as-presentation (stream symbol 'symbol :single-box :highlighting) - (cond ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #:) - (with-face (:keyword) - (call-next-method))) - ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #&) - (with-face (:lambda-list-keyword) - (call-next-method))) - ((and (symbolp symbol) - (macro-function symbol) - (form-operator-p syntax parse-symbol)) - (with-face (:macro) - (call-next-method))) - ((and (symbolp symbol) - (special-operator-p symbol) - (form-operator-p syntax parse-symbol)) - (with-face (:special-form) - (call-next-method))) - (t (call-next-method))))) - (call-next-method))) - -(defmethod display-parse-tree ((parser-symbol literal-object-form) stream (view textual-drei-syntax-view) - (syntax lisp-syntax)) - (updating-output - (stream :unique-id (list view parser-symbol) - :id-test #'equal - :cache-value parser-symbol - :cache-test #'eql) - (let ((object (form-to-object syntax parser-symbol))) - (present object (presentation-type-of object) :stream stream)))) - -(defmethod display-parse-tree ((parser-symbol lisp-lexeme) stream (view textual-drei-syntax-view) - (syntax lisp-syntax)) - (flet ((cache-test (t1 t2) - (and (eq t1 t2) - (eq (slot-value t1 'ink) - (medium-ink (sheet-medium stream))) - (eq (slot-value t1 'face) - (text-style-face (medium-text-style (sheet-medium stream))))))) - (updating-output - (stream :unique-id (list view parser-symbol) - :id-test #'equal - :cache-value parser-symbol - :cache-test #'cache-test) - (with-slots (ink face) parser-symbol - (setf ink (medium-ink (sheet-medium stream)) - face (text-style-face (medium-text-style (sheet-medium stream)))) - (write-string (form-string syntax parser-symbol) stream))))) - -(define-presentation-type lisp-string () - :description "lisp string") - -(defmethod display-parse-tree ((parse-symbol complete-string-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((children (children parse-symbol))) - (if (third children) - (let ((string (buffer-substring (buffer syntax) - (start-offset (second children)) - (end-offset (car (last children 2)))))) - (with-output-as-presentation (stream string 'lisp-string - :single-box :highlighting) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (loop until (null (cdr children)) - do (display-parse-tree (pop children) stream view syntax)) - (display-parse-tree (pop children) stream view syntax)))) - (with-face (:string) - (progn (display-parse-tree (pop children) stream view syntax) - (display-parse-tree (pop children) stream view syntax)))))) - -(defmethod display-parse-tree ((parse-symbol incomplete-string-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((children (children parse-symbol))) - (if (second children) - (let ((string (buffer-substring (buffer syntax) - (start-offset (second children)) - (end-offset (car (last children)))))) - (with-output-as-presentation (stream string 'lisp-string - :single-box :highlighting) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (loop until (null children) - do (display-parse-tree (pop children) stream view syntax))))) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax))))) - -(defmethod display-parse-tree ((parse-symbol line-comment-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (with-face (:comment) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol long-comment-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (with-face (:comment) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol reader-conditional-positive-form) - stream (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((conditional (second-noncomment (children parse-symbol)))) - (if (eval-feature-conditional conditional syntax) - (call-next-method) - (let ((*current-faces* *reader-conditional-faces*)) - (with-face (:reader-conditional) - (call-next-method)))))) - -(defmethod display-parse-tree ((parse-symbol reader-conditional-negative-form) - stream (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let ((conditional (second-noncomment (children parse-symbol)))) - (if (eval-feature-conditional conditional syntax) - (let ((*current-faces* *reader-conditional-faces*)) - (with-face (:reader-conditional) - (call-next-method))) - (call-next-method)))) - -(defgeneric eval-feature-conditional (conditional-form syntax)) - -(defmethod eval-feature-conditional (conditional-form (syntax lisp-syntax)) - nil) - -;; Adapted from slime.el - -(defconstant +keyword-package+ (find-package :keyword) - "The KEYWORD package.") - -(defmethod eval-feature-conditional ((conditional token-mixin) (syntax lisp-syntax)) - (let* ((string (form-string syntax conditional)) - (symbol (parse-symbol string :package +keyword-package+))) - (member symbol *features*))) - -(defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax)) - (let ((children (children conditional))) - (when (third-noncomment children) - (flet ((eval-fc (conditional) - (funcall #'eval-feature-conditional conditional syntax))) - (let* ((type (second-noncomment children)) - (conditionals (butlast - (nthcdr - 2 - (remove-if - #'comment-p - children)))) - (type-string (form-string syntax type)) - (type-symbol (parse-symbol type-string :package +keyword-package+))) - (case type-symbol - (:and (funcall #'every #'eval-fc conditionals)) - (:or (funcall #'some #'eval-fc conditionals)) - (:not (when conditionals - (funcall #'(lambda (f l) (not (apply f l))) - #'eval-fc conditionals))))))))) +;; Note that we do not colour keyword symbols or special forms yet, +;; that is because the only efficient way to do so is to mark them as +;; interesting in the parser itself, it is too slow to check for it in +;; highlighting rules. +(make-syntax-highlighting-rules emacs-style-highlighting + (error-symbol (:face :ink +red+)) + (string-form (:face :ink +rosy-brown+ + :style (make-text-style nil :italic nil))) + (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large)))) + +(defparameter *syntax-highlighting-rules* 'emacs-style-highlighting + "The syntax highlighting rules used for highlighting Lisp +syntax.")

-(defmethod display-parse-tree ((parse-symbol complete-list-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (let* ((children (children parse-symbol)) - (point-offset (the fixnum (offset (point view)))) - ;; The following is true if the location if the point - ;; warrants highlighting of a set of matching parentheses. - (should-highlight (and (active view) - (or (= (the fixnum (end-offset parse-symbol)) point-offset) - (= (the fixnum (start-offset parse-symbol)) point-offset))))) - (if should-highlight - (with-text-face (stream :bold) - (display-parse-tree (car children) stream view syntax)) - (display-parse-tree (car children) stream view syntax)) - (loop for child-list on (cdr children) - if (and should-highlight (null (cdr child-list))) do - (with-text-face (stream :bold) - (display-parse-tree (car child-list) stream view syntax)) - else do - (display-parse-tree (car child-list) stream view syntax)))) - -(defmethod display-parse-tree ((parse-symbol incomplete-list-form) stream - (view textual-drei-syntax-view) (syntax lisp-syntax)) - (update-parse syntax) - (let* ((children (children parse-symbol)) - (point-offset (the fixnum (offset (point view)))) - ;; The following is set to true if the location if the point - ;; warrants highlighting of the beginning parenthesis - (should-highlight (and (active view) - (= (the fixnum (start-offset parse-symbol)) point-offset)))) - (with-face (:error) - (if should-highlight - (with-text-face (stream :bold) - (display-parse-tree (car children) stream view syntax)) - (display-parse-tree (car children) stream view syntax))) - (loop for child in (cdr children) do - (display-parse-tree child stream view syntax)))) +(defmethod syntax-highlighting-rules ((syntax lisp-syntax)) + *syntax-highlighting-rules*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/02 14:43:40 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/03 12:32:08 1.7 @@ -28,7 +28,8 @@ (in-package :drei-lr-syntax)

(defclass lr-syntax-mixin () - ((stack-top :initform nil) + ((stack-top :initform nil + :accessor stack-top) (potentially-valid-trees) (lookahead-lexeme :initform nil :accessor lookahead-lexeme) (current-state) @@ -289,6 +290,66 @@

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Utility functions + +(defun invoke-do-parse-symbols-forward (start-offset nearby-symbol fn) + "Loop across the parse symbols of the syntax, calling `fn' on +any parse symbol that starts at or after +`start-offset'. `Nearby-symbol' is the symbol at which the +iteration will start. First, if `nearby-symbol' is at or after +`start-offset', `fn' will be called on +`nearby-symbol'. Afterwards, the children of `nearby-symbol' will +be looped over. Finally, the process will be repeated for each +sibling of `nearby-symbol'. It is guaranteed that `fn' will not +be called twice for the same parser symbol." + (labels ((act (parse-symbol previous) + (when (>= (end-offset parse-symbol) start-offset) + (when (>= (start-offset parse-symbol) start-offset) + (funcall fn parse-symbol)) + (loop for child in (children parse-symbol) + unless (eq child previous) + do (act child parse-symbol))) + (unless (or (null (parent parse-symbol)) + (eq (parent parse-symbol) previous)) + (act (parent parse-symbol) parse-symbol)))) + (act nearby-symbol nearby-symbol))) + +(defmacro do-parse-symbols-forward ((symbol start-offset enclosing-symbol) + &body body) + "Loop across the parse symbols of the syntax, evaluating `body' +with `symbol' bound for each parse symbol that starts at or after +`start-offset'. `enclosing-symbol' is the symbol at which the +iteration will start. First, if `enclosing-symbol' is at or after +`start-offset', `symbol' will be bound to +`enclosing-symbol'. Afterwards, the children of +`enclosing-symbol' will be looped over. Finally, the process will +be repeated for each sibling of `nearby-symbol'. It is guaranteed +that `symbol' will not bound to the same parser symbol twice." + `(invoke-do-parse-symbols-forward ,start-offset ,enclosing-symbol + #'(lambda (,symbol) + ,@body))) + +(defun parser-symbol-containing-offset (syntax offset) + "Find the most specific (leaf) parser symbol in `syntax' that +contains `offset'. If there is no such parser symbol, return the +stack-top of `syntax'." + (labels ((check (parser-symbol) + (cond ((or (and (<= (start-offset parser-symbol) offset) + (< offset (end-offset parser-symbol))) + (= offset (start-offset parser-symbol))) + (return-from parser-symbol-containing-offset + (if (null (children parser-symbol)) + parser-symbol + (or (check-children (children parser-symbol)) + parser-symbol)))) + (t nil))) + (check-children (children) + (find-if #'check children))) + (or (check-children (children (stack-top syntax))) + (stack-top syntax)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; update syntax

(defmethod update-syntax ((syntax lr-syntax-mixin) prefix-size suffix-size @@ -317,85 +378,182 @@

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Redisplay. This is just some minor conveniences, not an actual -;;; generic redisplay implementation for LR syntaxes. - -(defvar *current-faces* nil - "The current faces used by the syntax for redisplay. Will be -bound during redisplay.") - -(defstruct (face (:type list) - (:constructor make-face (name colour &optional style))) - name colour (style nil)) - -(defgeneric get-faces (syntax) - (:documentation "Return a list of all the defined standard -faces of `syntax'.") +;;; General redisplay for LR syntaxes, subclasses of `lr-syntax-mixin' +;;; should be able to easily define some syntax rules, and need not +;;; bother with all this complexity. +;;; +;;; _______________ +;;; / \ +;;; / \ +;;; / \ +;;; | XXXX XXXX | +;;; | XXXX XXXX | +;;; | XXX XXX | +;;; | X | +;;; __ XXX __/ +;;; |\ XXX /| +;;; | | | | +;;; | I I I I I I I | +;;; | I I I I I I | +;;; _ _/ +;;; _ _/ +;;; _______/ +;;; XXX XXX +;;; XXXXX XXXXX +;;; XXXXXXXXX XXXXXXXXXX +;;; XXXXX XXXXX +;;; XXXXXXX +;;; XXXXX XXXXX +;;; XXXXXXXXX XXXXXXXXXX +;;; XXXXX XXXXX +;;; XXX XXX + +(defmacro make-syntax-highlighting-rules (name &body rules) + "Define a set of rules for highlighting a syntax. `Name', which +must be a symbol, is the name of this set of rules, and will be +bound to a function implementing the rules. `Rules' is a list of +rules of the form `(parser-symbol (type args...))', where +`parser-symbol' is a type that might be encountered in a parse +tree for the syntax. The rule specifies how to highlight that +kind of object (and all its children). `Type' can be one of three +symbols. + + `:face', in which case `args' will be used as arguments to a + call to `make-face'. The resulting face will be used to draw + the parsersymbol. + + `:options', in which case `args' will be used as arguments to + `make-drawing-options'. The resulting options will be used to + draw the parser symbol. + + `:function', in which case `args' must be a single element, a + function that takes two arguments. These arguments are the + syntax and the parser symbol, and the return value of this + function is the `drawing-options' object that will be used to + draw the parser-symbol." + (check-type name symbol) + `(progn + (fmakunbound ',name) + (defgeneric ,name (syntax parser-symbol) + (:method (syntax (parser-symbol parser-symbol)) + nil)) + ,@(flet ((make-rule-exp (type args) + (ecase type + (:face `#'(lambda (syntax parser-symbol) + (declare (ignore syntax parser-symbol)) + (make-drawing-options :face (make-face ,@args)))) + (:options `#'(lambda (syntax parser-symbol) + (declare (ignore syntax parser-symbol)) + (make-drawing-options ,@args))) + (:function (first args))))) + (loop for (parser-symbol (type . args)) in rules + collect `(let ((rule ,(make-rule-exp type args))) + (defmethod ,name (syntax (parser-symbol ,parser-symbol)) + (funcall rule syntax parser-symbol))))))) + +(make-syntax-highlighting-rules default-syntax-highlighting) + +(defgeneric syntax-highlighting-rules (syntax) + (:documentation "Return the drawing options that should be used +for displaying `parser-symbol's for `syntax'. A method should be +defined on this function for any syntax that wants syntax +highlighting.") (:method ((syntax lr-syntax-mixin)) - '())) + 'default-syntax-highlighting))

-(defun get-face (name) - "Retrieve face named `name' from `*current-faces*'." - (find name *current-faces* :key #'face-name)) - -(defmacro define-standard-faces (syntax &body faces) - "Define the list of standard faces used by `syntax' to be -`faces', which must be a sequence of forms evaluating to -face-values ((name, colour, style)-triples)." - `(let ((faces-list (list ,@faces))) - (defmethod get-faces ((syntax ,syntax)) - faces-list))) - -(defmacro with-face ((face &optional (stream-symbol 'stream)) &body body) - `(with-drawing-options (,stream-symbol :ink (face-colour (get-face ,face)) - :text-style (face-style (get-face ,face))) - ,@body)) - -(defgeneric display-parse-tree (parse-symbol stream view syntax) - (:documentation "Display the given parse-symbol on `stream', -assuming `view' to be the relevant Drei vire and `syntax' being -the syntax object responsible for the parse symbol.")) - -(defmethod display-parse-tree :before ((parse-symbol lexeme) - stream (view textual-drei-syntax-view) - (syntax lr-syntax-mixin)) - (handle-whitespace stream view (buffer view) - *white-space-start* (start-offset parse-symbol)) - (setf *white-space-start* (end-offset parse-symbol))) - -(defmethod display-parse-tree :around ((parse-symbol parser-symbol) - stream (view textual-drei-syntax-view) - (syntax lr-syntax-mixin)) - (with-accessors ((top top) (bot bot)) view - (when (and (start-offset parse-symbol) - (mark< (start-offset parse-symbol) bot) - (mark> (end-offset parse-symbol) top)) - (call-next-method)))) - -(defmethod display-parse-tree ((parse-symbol parser-symbol) - stream (view textual-drei-syntax-view) - (syntax lr-syntax-mixin)) - (with-accessors ((top top) (bot bot)) view - (loop for child in (children parse-symbol) - when (and (start-offset child) - (mark> (end-offset child) top)) - do (if (mark< (start-offset child) bot) - (display-parse-tree child stream view syntax) - (return))))) - -(defmethod display-syntax-view ((stream clim-stream-pane) (view textual-drei-syntax-view) - (syntax lr-syntax-mixin)) - (update-parse syntax) - (with-accessors ((top top) (bot bot)) view - (with-accessors ((cursor-positions cursor-positions)) view - ;; There must always be room for at least one element of line - ;; information. - (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot)) - :initial-element nil) - *current-line* 0 - (aref cursor-positions 0) (multiple-value-list - (stream-cursor-position stream)))) - (setf *white-space-start* (offset top))) - (let ((*current-faces* (get-faces syntax))) - (with-slots (stack-top) syntax - (display-parse-tree stack-top stream view syntax)))) +(defun get-drawing-options (highlighting-rules syntax parse-symbol) + "Get the drawing options with which `parse-symbol' should be +drawn. If `parse-symbol' is NIL, return NIL." + (when parse-symbol + (funcall highlighting-rules syntax parse-symbol))) + +(defstruct (pump-state + (:constructor make-pump-state + (parser-symbol offset drawing-options + highlighting-rules))) + "A pump state object used in the LR syntax +module. `parser-symbol' is the a parse symbol object `offset' is +in. `Drawing-options' is a stack with elements `(end-offset +drawing-options)', where `end-offset' specifies there the drawing +options specified by `drawing-options' stop. `Highlighting-rules' +is the rules that are used for syntax highlighting." + parser-symbol offset + drawing-options highlighting-rules) + +(defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) + (syntax lr-syntax-mixin) (offset integer)) + (update-parse syntax 0 offset) + (let ((parser-symbol (parser-symbol-containing-offset syntax offset)) + (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 syntax parser-symbol))) + (if (null drawing-options) + (initial-drawing-options (parent parser-symbol)) + (cons (end-offset parser-symbol) drawing-options)))))) + (make-pump-state parser-symbol offset + (list (initial-drawing-options parser-symbol) + (cons (1+ (size (buffer view))) +default-drawing-options+)) + highlighting-rules)))) + +(defun find-next-stroke-end (syntax pump-state) + "Assuming that `pump-state' contains the previous pump state, +find out where the next stroke should end, and possibly push some +drawing options onto `pump-state'." + (with-accessors ((start-symbol pump-state-parser-symbol) + (offset pump-state-offset) + (drawing-options pump-state-drawing-options) + (highlighting-rules pump-state-highlighting-rules)) + pump-state + (let ((line (line-containing-offset syntax offset))) + (flet ((finish (offset symbol &optional stroke-drawing-options) + (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) + drawing-options)) + (return-from find-next-stroke-end + offset))) + (if (null start-symbol) + ;; This means that all remaining lines are blank. + (finish (line-end-offset line) nil) + (or (do-parse-symbols-forward (symbol offset start-symbol) + (let ((symbol-drawing-options + (get-drawing-options highlighting-rules syntax symbol))) + (cond ((> (start-offset symbol) (line-end-offset line)) + (finish (line-end-offset line) start-symbol)) + ((and (> (start-offset symbol) offset) + (not (drawing-options-equal (or symbol-drawing-options + +default-drawing-options+) + (cdr (first drawing-options))))) + (finish (start-offset symbol) symbol symbol-drawing-options)) + ((and (= (start-offset symbol) offset) + (offset-beginning-of-line-p (buffer syntax) offset) + (and symbol-drawing-options + (not (drawing-options-equal symbol-drawing-options + (cdr (first drawing-options)))))) + (finish (start-offset symbol) symbol symbol-drawing-options))))) + ;; If there are no more parse symbols, we just go + ;; line-by-line from here. This should mean that all + ;; remaining lines are blank. + (finish (line-end-offset line) nil))))))) + +(defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) + (syntax lr-syntax-mixin) stroke + (pump-state pump-state)) + ;; `Pump-state' will be destructively modified. + (prog1 pump-state + (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 syntax pump-state))) + (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)))))) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/02 14:43:40 1.29 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/03 12:32:08 1.30 @@ -169,8 +169,6 @@ #:display-syntax-name #:syntax-line-indentation #:eval-defun - #:record-line-vertical-offset - #:line-vertical-offset #:syntax-line-comment-string #:line-comment-region #:comment-region #:line-uncomment-region #:uncomment-region @@ -487,13 +485,15 @@ (:use :clim-lisp :clim :drei-buffer :drei-base :drei-syntax :flexichain :drei :drei-core) (:export #:fundamental-syntax #:scan - #:*current-line* #:*white-space-start* #:handle-whitespace) + #:start-mark #:line-length #:line-end-offset + #:line-containing-offset #:offset-in-line-p) (:documentation "Implementation of the basic syntax module for editing plain text."))

(defpackage :drei-lr-syntax (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base - :drei-syntax :drei :drei-core :drei-fundamental-syntax) + :drei-syntax :drei :drei-core :drei-fundamental-syntax + :esa-utils) (:export #:lr-syntax-mixin #:stack-top #:initial-state #:skip-inter #:lex #:define-lexer-state #:lexer-toplevel-state #:lexer-error-state @@ -505,10 +505,8 @@ #:action #:new-state #:done #:reduce-fixed-number #:reduce-until-type #:reduce-all #:error-state #:error-reduce-state - #:*current-faces* - #:make-face #:face-name #:face-colour #:face-style - #:get-faces #:define-standard-faces #:with-face - #:display-parse-tree) + #:make-syntax-highlighting-rules + #:syntax-highlighting-rules) (:documentation "Underlying LR parsing functionality."))

(defpackage :drei-lisp-syntax @@ -564,8 +562,6 @@ #:at-end-of-string-p #:at-beginning-of-children-p #:at-end-of-children-p - #:structurally-at-beginning-of-children-p - #:structurally-at-end-of-children-p #:comment-at-mark

;; Lambda list classes.