[climacs-cvs] CVS climacs
crhodes
crhodes at common-lisp.net
Wed Jan 16 18:15:18 UTC 2008
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv26184
Modified Files:
prolog-syntax.lisp
Log Message:
First cut at syntax (lexeme) highlighting for prolog in the new
stroke/pump world.
There seem to be some cases where we're calling update-syntax with weird
values, which seem to cause confusion in other places. Some potential
work-saving optimizations are disabled, but despite that it doesn't seem
to be too slow on SWI Prolog's library/url.pl file.
--- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/15 16:54:37 1.35
+++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/16 18:15:18 1.36
@@ -1134,6 +1134,13 @@
(defmethod update-syntax esa-utils:values-max-min ((syntax prolog-syntax) prefix-size suffix-size &optional begin end)
(declare (ignore begin))
+ ;; FIXME: this isn't quite right; it's possible that an edit has
+ ;; occurred out of view, destroying our parse-up-to-end-lexeme
+ ;; invariant. Actually it also seems to be wrong, maybe because
+ ;; there's something weird in views.lisp? Dunno.
+ #+nil
+ (when (< end prefix-size)
+ (return-from update-syntax (values 0 prefix-size)))
(with-slots (lexer valid-parse) syntax
(let* ((low-mark (make-buffer-mark (buffer syntax) prefix-size :left))
(high-mark (make-buffer-mark
@@ -1227,145 +1234,100 @@
(values 0 (offset scan))))))
;;; display
-#+nil ; old, not based on stroking pumps.
-(progn
-(defvar *white-space-start* nil)
-
-(defvar *current-line* 0)
-
-(defun handle-whitespace (pane buffer start end)
- (let ((space-width (space-width pane))
- (tab-width (tab-width pane)))
- (with-sheet-medium (medium pane)
- (with-accessors ((cursor-positions cursor-positions)) (syntax buffer)
- (loop while (< start end)
- do (case (buffer-object buffer start)
- (#\Newline (record-line-vertical-offset pane (syntax buffer) (incf *current-line*))
- (terpri pane)
- (stream-increment-cursor-position
- pane (first (aref cursor-positions 0)) 0))
- ((#\Page #\Return #\Space) (stream-increment-cursor-position
- pane space-width 0))
- (#\Tab (let ((x (stream-cursor-position pane)))
- (stream-increment-cursor-position
- pane (- tab-width (mod x tab-width)) 0))))
- (incf start))))))
-
-(defmethod display-parse-tree :around ((entity prolog-parse-tree) (syntax prolog-syntax)
- (stream extended-output-stream) (drei drei))
- (with-slots (top bot) drei
- (when (and (end-offset entity)
- (mark> (end-offset entity) top))
- (call-next-method))))
-
-(defmethod display-parse-tree ((entity prolog-token) (syntax prolog-syntax)
- (stream extended-output-stream) (drei drei))
- (with-slots (top bot) drei
- (let ((string (coerce (buffer-sequence (buffer syntax)
- (start-offset entity)
- (end-offset entity))
- 'string)))
- (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))))
- (eq (slot-value t1 'start)
- (max 0 (- (offset top) (start-offset entity))))
- (eq (slot-value t1 'end)
- (- (length string)
- (max 0 (- (end-offset entity) (offset bot))))))))
- (updating-output (stream :unique-id entity
- :id-test #'eq
- :cache-value entity
- :cache-test #'cache-test)
- (with-slots (ink face start end) entity
- (setf ink (medium-ink (sheet-medium stream))
- face (text-style-face (medium-text-style (sheet-medium stream)))
- start (max 0 (- (offset top) (start-offset entity)))
- end (- (length string)
- (max 0 (- (end-offset entity) (offset bot)))))
- (let ((start start)
- (end end))
- (loop
- (when (>= start end)
- (return))
- (let ((nl (position-if
- (lambda (x) (member x '(#\Tab #\Newline)))
- string :start start :end end)))
- (unless nl
- (present (subseq string start end) 'string :stream stream)
- (return))
- (present (subseq string start nl) 'string :stream stream)
- (handle-whitespace stream (buffer drei)
- (+ (start-offset entity) nl)
- (+ (start-offset entity) nl 1))
- (setf start (+ nl 1)))))))))))
-
-(defmethod display-parse-tree :before ((entity prolog-token) (syntax prolog-syntax)
- (stream extended-output-stream) (drei drei))
- (handle-whitespace stream (buffer drei) *white-space-start* (start-offset entity))
- (setf *white-space-start* (end-offset entity)))
-
-(defgeneric display-parse-stack (symbol stack syntax stream drei))
-
-(defmethod display-parse-stack (symbol stack (syntax prolog-syntax)
- (stream extended-output-stream) (drei drei))
- (let ((next (parse-stack-next stack)))
- (unless (null next)
- (display-parse-stack (parse-stack-symbol next) next syntax stream drei))
- (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
- do (display-parse-tree parse-tree syntax stream drei))))
-
-(defun display-parse-state (state syntax stream drei)
- (let ((top (parse-stack-top state)))
- (if (not (null top))
- (display-parse-stack (parse-stack-symbol top) top syntax stream drei)
- (display-parse-tree (target-parse-tree state) syntax stream drei))))
-
-(defun nb-valid-lexemes (lexer)
- (slot-value lexer 'valid-lex))
-
-(defmethod display-drei-contents ((stream clim-stream-pane) (drei drei) (syntax prolog-syntax))
- (with-slots (top bot) drei
- (with-accessors ((cursor-positions cursor-positions)) syntax
- (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))
- (with-slots (lexer) syntax
- (let ((average-token-size (max (float (/ (size (buffer drei)) (nb-valid-lexemes lexer)))
- 1.0)))
- ;; find the last token before bot
- (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
- ;; go back to a token before bot
- (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
- do (decf end-token-index))
- ;; go forward to the last token before bot
- (loop until (or (= end-token-index (nb-valid-lexemes lexer))
- (mark> (start-offset (lexeme lexer end-token-index)) bot))
- do (incf end-token-index))
- (let ((start-token-index end-token-index))
- ;; go back to the first token after top, or until the previous token
- ;; contains a valid parser state
- (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
- (not (parse-state-empty-p
- (slot-value (lexeme lexer (1- start-token-index)) 'state))))
- do (decf start-token-index))
- ;; display the parse tree if any
- (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
- (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
- syntax stream drei))
- ;; display the lexemes
- (with-drawing-options (stream :ink +red+)
- (loop while (< start-token-index end-token-index)
- do (let ((token (lexeme lexer start-token-index)))
- (display-parse-tree token syntax stream drei))
- (incf start-token-index)))))))))
-) ; PROGN
+(defclass pump-state ()
+ ((drawing-options :initarg :drawing-options :accessor drawing-options)
+ (lexeme-index :initarg :lexeme-index :accessor lexeme-index)
+ (offset :initarg :offset :accessor pump-state-offset)))
+
+(defun make-pump-state (drawing-options lexeme-index offset)
+ (make-instance 'pump-state :drawing-options drawing-options
+ :lexeme-index lexeme-index :offset offset))
+
+(defun %lexeme-index-before-offset (syntax offset)
+ (update-parse syntax 0 offset)
+ (with-slots (drei-syntax::lexemes valid-lex)
+ (lexer syntax)
+ ;; FIXME: speed this up.
+ (do* ((i (1- valid-lex) (1- i))
+ (lexeme #1=(element* drei-syntax::lexemes i) #1#)
+ (start #2=(start-offset lexeme) #2#))
+ ((<= start offset) i))))
+
+(defun %drawing-options-for-lexeme-index (syntax index)
+ (with-slots (drei-syntax::lexemes)
+ (lexer syntax)
+ (typecase (element* drei-syntax::lexemes index)
+ (comment-lexeme *comment-drawing-options*)
+ (char-code-list-lexeme *string-drawing-options*)
+ (variable-lexeme *special-variable-drawing-options*)
+ (t +default-drawing-options+))))
+
+(defmethod pump-state-for-offset-with-syntax
+ ((view textual-drei-syntax-view) (syntax prolog-syntax) (offset cl:integer))
+ (let ((index (%lexeme-index-before-offset syntax offset)))
+ (make-pump-state (%drawing-options-for-lexeme-index syntax index) index offset)))
+
+(defmethod stroke-pump-with-syntax
+ ((view textual-drei-syntax-view) (syntax prolog-syntax)
+ stroke (pump-state pump-state))
+ (with-slots (drei-syntax::lexemes) (lexer syntax)
+ (let* ((index (lexeme-index pump-state))
+ (offset (pump-state-offset pump-state))
+ (line (line-containing-offset syntax offset))
+ (lexeme (and index (element* drei-syntax::lexemes index))))
+ (cond
+ ((or
+ ;; in theory, if INDEX is null everything should be blank lines
+ (null index)
+ ;; if we're not in a lexeme, by definition we
+ ;; have blank space
+ (< (line-end-offset line) (start-offset lexeme)))
+ (setf (stroke-start-offset stroke) offset
+ (stroke-end-offset stroke) (line-end-offset line)
+ (stroke-drawing-options stroke) +default-drawing-options+)
+ (setf (pump-state-offset pump-state) (1+ (line-end-offset line)))
+ pump-state)
+ ((< (line-end-offset line) (end-offset lexeme))
+ (setf (stroke-start-offset stroke) offset
+ (stroke-end-offset stroke) (line-end-offset line)
+ (stroke-drawing-options stroke) (drawing-options pump-state))
+ (setf (pump-state-offset pump-state) (1+ (line-end-offset line)))
+ pump-state)
+ (t
+ ;; before deciding what happens next, we need to ensure that
+ ;; we have given the parser a chance to lex and parse beyond
+ ;; the last lexeme.
+ (when (= (1+ index) (slot-value (lexer syntax) 'valid-lex))
+ (let ((next (min (size (buffer syntax))
+ (1+ (drei::prefix-size view)))))
+ (update-parse syntax 0 next)))
+ (cond
+ ((< (1+ index) (nb-lexemes (lexer syntax)))
+ (let* ((new-index (1+ index))
+ (new-lexeme (lexeme (lexer syntax) new-index))
+ (end-offset (min (start-offset new-lexeme)
+ (line-end-offset line))))
+ (setf (stroke-start-offset stroke) offset
+ (stroke-end-offset stroke) end-offset
+ (stroke-drawing-options stroke) (drawing-options pump-state))
+ (setf (pump-state-offset pump-state) (if (= end-offset (line-end-offset line))
+ (1+ end-offset)
+ end-offset)
+ (drawing-options pump-state) (%drawing-options-for-lexeme-index syntax new-index)
+ (lexeme-index pump-state) new-index))
+ pump-state)
+ (t
+ (let ((end-offset (end-offset lexeme)))
+ (setf (stroke-start-offset stroke) offset
+ (stroke-end-offset stroke) end-offset
+ (stroke-drawing-options stroke) (drawing-options pump-state))
+ (setf (pump-state-offset pump-state) (if (= end-offset (line-end-offset line))
+ (1+ end-offset)
+ end-offset)
+ (drawing-options pump-state) +default-drawing-options+
+ (lexeme-index pump-state) nil)
+ pump-state))))))))
+
#|
(climacs-gui::define-named-command com-inspect-lex ()
(with-slots (lexer) (slot-value (buffer (climacs-gui::current-window)) 'drei-syntax::syntax)
More information about the Climacs-cvs
mailing list