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.
