source: trunk/source/contrib/foy/syntax-styling/syntax-styling-comments.lisp @ 13040

Last change on this file since 13040 was 13040, checked in by gfoy, 11 years ago

Contrib: syntax-styling

File size: 19.6 KB
Line 
1;;;-*- Mode: Lisp; Package: (SYNTAX-STYLING (CL CCL HEMLOCK-INTERNALS)) -*-
2
3;;; ****************************************************************************
4;;;
5;;;      syntax-styling-comments.lisp
6;;;
7;;;      copyright © 2009 Glen Foy, all rights reserved,
8;;;
9;;;     These classes support the styling of semi-colon and sharp-stroke comments,
10;;;     and strings.  Most unusual cases are correctly handled: strings embedded in
11;;;     comments, comments inside of strings, etc.
12;;;
13;;;      Mod history, most recent first:
14;;;      10/18/9   first cut.
15;;;
16;;; ****************************************************************************
17
18(in-package "SAX")
19
20
21;;; ----------------------------------------------------------------------------
22;;;
23(defClass STYLED-COMMENT ()
24  ((comment-start :initarg :comment-start :initform nil :reader comment-start)
25   (comment-end :initform nil :initarg :comment-end :reader comment-end))
26  (:documentation "Support for styled comments."))
27
28(defClass STYLED-SEMI-COLON-COMMENT (styled-comment) ())
29
30(defClass STYLED-SHARP-COMMENT (styled-comment) ())
31
32(defMethod style-comment ((comment styled-semi-colon-comment))
33  (set-style-attributes (attribute-dictionary *semi-colon-comment-style*)
34                        (comment-start comment) (comment-end comment)))
35
36(defMethod style-comment ((comment styled-sharp-comment))
37  (set-style-attributes (attribute-dictionary *sharp-comment-style*)
38                        (comment-start comment) (comment-end comment)))
39
40;;; ----------------------------------------------------------------------------
41;;;
42(defClass STYLED-STRING ()
43  ((string-start :initarg :string-start :initform nil :reader string-start)
44   (string-end :initform nil :initarg :string-end :reader string-end))
45  (:documentation "Support for styled strings."))
46
47(defMethod style-string ((string styled-string))
48  (cond (*inc-p* ; if dynamic, never style past *inc-pos*
49         (set-style-attributes (attribute-dictionary *string-style*)
50                               (string-start string) *inc-pos*))
51        (t
52         (set-style-attributes (attribute-dictionary *string-style*)
53                               (string-start string) (string-end string)))))
54
55;;; ----------------------------------------------------------------------------
56;;;
57(defClass SEGMENT-ARRAY ()
58  ((array :initarg :array :reader segment-array-array)
59   (length :initarg :length :accessor segment-array-length))
60  (:documentation 
61   "A sorted 2d array of the start and end positions for segments  in
62a buffer.  There are three segment types: strings, semi-colon comments,
63and sharp-stroke comments.  The method not-embedded-in-segment-p does
64 a binary search for the position of a particular char to see if the
65char is embedded."))
66
67(defMethod print-object ((array segment-array) stream)
68  (declare (ignore stream))
69  #+sax-debug (when *print-object-segment-array-debug*
70                (dump-segment-array array))
71  #-sax-debug (call-next-method))
72
73(defmethod dump-segment-array ((a segment-array))
74  (format t "~%~%segment-array length: ~S" (segment-array-length a))
75  (dotimes (idx (segment-array-length a))
76    (format t "~%   ~S" (aref (segment-array-array a) idx 0))
77    (format t "~%   ~S~%" (aref (segment-array-array a) idx 1))))
78
79(defun unify-segment-lists (segment-list-1 segment-list-2)
80  "Merge two lists, discarding segments which are embedded in segments of the other list."
81  (do* ((list-1 segment-list-1)
82        (list-2 segment-list-2)
83        (segment-1 (first list-1) (first list-1))
84        (segment-2 (first list-2) (first list-2))
85        (unified-list nil))
86       ((and (endp list-1) (endp list-2)) (nreverse unified-list))
87    (cond ((and list-1 list-2)
88           (cond ((mark< (first segment-1) (first segment-2))
89                  (cond ((mark< (first segment-2) (second segment-1))
90                         (pop list-2))
91                        (t 
92                         (push segment-1 unified-list)
93                         (pop list-1))))
94                 (t
95                  (cond ((mark< (first segment-1) (second segment-2))
96                         (pop list-1))
97                        (t 
98                         (push segment-2 unified-list)
99                         (pop list-2))))))
100          (t ; one list is empty - add what's left of the other
101           (cond ((endp list-1)
102                  (return (append (nreverse unified-list) list-2)))
103                 (t
104                  (return (append (nreverse unified-list) list-1))))))))
105
106(defun make-segment-array (table)
107  "Constructor for the segment-array class."
108  (let ((table-length (length table)))
109    (make-instance 'segment-array
110      :length table-length
111      :array (make-array `(,table-length 2)
112                         :initial-contents table))))
113
114;;; This is called when constructing the segment array and to get a list of strings
115;;; to style. When styling dynamically, cull the string list. When constructing the
116;;; segment array, don't.
117;;;
118(defun create-string-list (start end  &optional styling-p)
119  "Return a list of the form, (start end), for each string in buffer.
120The list is in reverse order."
121  (flet ((semi-colon-commented-p (pos)
122           (do* ((start (mark-move pos 0) (nmark-next start))
123                 (char (mark-char start) (mark-char start)))
124                ((mark>= start pos))
125             (when (char= char #\;) (return-from semi-colon-commented-p t))))
126         (sharp-stroke-commented-p (pos)
127           (do ((start (clone pos) (nmark-prev start))
128                (char (mark-char start) (mark-char start))
129                (char-minus-one 
130                 (when (>= (mark-charpos start) 1) (mark-char (mark-prev pos)))
131                 (when (>= (mark-charpos start) 1) (mark-char (mark-prev pos)))))
132               ((or (= (mark-charpos start) 1)
133                    (and (char= char #\#) (char= char-minus-one #\|))))
134             (when (and (char= char #\|) 
135                        (char= char-minus-one #\|))
136               (return-from sharp-stroke-commented-p t)))))
137    (do* ((position (clone start))
138          string-list string-end)
139         ((or (null position) (mark>= position end)) string-list)
140      (cond ((and (eql (mark-char position) #\") 
141                  (not (eql (mark-char (if (> (mark-charpos position) 0)
142                                         (mark-prev position)
143                                         position)) #\\))
144                  ;; Too expensive; may have a rare mis-styled file
145                  ;; because of an unmatched quote in a sharp-comment.
146                  ;; (not (sharp-stroke-commented-p position))
147                  (not (semi-colon-commented-p position)))
148             (setf string-end (sexpr-end position))
149             (cond ((and string-end (mark<= string-end end))
150                    ;; Support for dynamic styling - only cull the string list
151                    ;; when styling strings, not when constructing the segment array
152                    (if *inc-p* 
153                      (if styling-p
154                        ;; cull
155                        (when (and (mark>= *inc-pos* position)
156                                   (mark<= *inc-pos* string-end))
157                          (push (list position string-end) string-list))
158                        (push (list position string-end) string-list))
159                      (push (list position string-end) string-list))
160                    (setf position (clone string-end)))
161                   (t 
162                    (return string-list))))
163            (t 
164             (nmark-next position))))))
165
166;;; This is only called by get-combined-segment-list, when doing vanilla styling.
167(defun create-semi-colon-comment-list (start end )
168   "Return a list of the form, (start end), for each comment in buffer."
169   (do* ((position (clone start))
170         comment-list comment-end)
171        ((or (null position) (mark> position end)) (nreverse comment-list))
172      (cond ((and (eql (mark-char position) #\;) 
173                  (mark> position (buf-start-mark)) ; *** mode line ???
174                  (not (eql (mark-char (mark-prev position)) #\\)))
175              (setf comment-end (line-end (clone position)))
176              (cond ((and comment-end (mark<= comment-end end))
177                      (push (list (clone position) (mark-next comment-end)) comment-list)
178                      (setf position (mark-next comment-end)))
179                     (t ; hum ...
180                      (setf position (mark-next position)))))
181             (t
182              (setf position (mark-next position))))))
183
184;;; This is only called by get-combined-segment-list, when doing vanilla styling.
185(defun create-sharp-stroke-comment-list (start end )
186  "Return a list of the form, (start end), for each comment in buffer."
187  (do* ((position (clone start))
188        comment-list comment-end)
189       ((or (null position) (mark> position end)) (nreverse comment-list))
190    (cond ((and (eql (mark-char position) #\#)
191                (eql (mark-char (mark-next position)) #\|)
192                (mark> position (buf-start-mark))
193                (not (eql (mark-char (mark-prev position)) #\\)))
194           (setf comment-end (pattern-search position *stroke-sharp-forward-pattern* end))
195           (cond ((and comment-end (mark<= comment-end end))
196                  (push (list position comment-end) comment-list)
197                  (setf position (mark-next comment-end)))
198                 (t 
199                  (return (nreverse comment-list)))))
200          (t
201           (setq position (mark-next position))))))
202
203;;; This is only called by get-combined-segment-list, when doing vanilla styling.
204(defun create-cocoa-syntax-list (start end pattern)
205  "Return a list of the form, (start end), for each Cocoa function name in buffer."
206  (do* ((position (pattern-search (clone start) pattern end)
207                  (pattern-search (clone name-end) pattern end))
208        (name-end (when position (sexpr-end position)) (when position (sexpr-end position)))
209        name-list)
210       ((or (null position) (null name-end) (mark> position end)) (nreverse name-list))
211    (push (list position name-end) name-list)))
212
213(defMethod not-embedded-in-segment-p ((array segment-array) position)
214  ;; Do a binary search of the segment-array to see if the position is embedded.
215  #+sax-debug (when *not-embedded-in-segment-p-debug*
216               (debug-out "~%~%~S" 'not-embedded-in-segment-p)
217               (dump-segment-array array)
218               (debug-out "~%position: ~S" position))
219  (when (or (zerop (segment-array-length array)) (null position))
220    (return-from not-embedded-in-segment-p t))
221  (do* ((top (1- (segment-array-length array)))
222        (bottom 0)
223        (index (truncate (+ bottom top) 2) (truncate (+ bottom top) 2)))
224       ((< top bottom) t)
225    (when (and (mark< (aref (segment-array-array array) index 0) position)
226               (mark> (aref (segment-array-array array) index 1) position))
227      ;; embedded - return the end of the containing segment as the second value:
228      (return (values nil (aref (segment-array-array array) index 1))))
229    (cond ((mark<= position (aref (segment-array-array array) index 0))
230           (setf top (1- index)))
231          ((mark>= position (aref (segment-array-array array) index 1))
232           (setf bottom (1+ index)))
233          (t (error "~&Bad value in binary search: ~a" position)))))
234
235(defun embedded-in-segment-p (pos)
236  (when *segment-array*
237    (multiple-value-bind (not-embedded-p end-of-segment)
238                         (not-embedded-in-segment-p *segment-array* pos)
239      (values (not not-embedded-p) end-of-segment))))
240
241(defun style-strings (&optional (start (buf-start-mark)) (end (buf-end-mark))
242                                &aux string-instances)
243  #+sax-debug (when *style-strings-debug*
244               (debug-out "~%~%~S" 'style-strings))
245  (setf *segment-list* (create-string-list start end *inc-p*))
246  (do* ((string-list *segment-list* (rest string-list))
247        (start-string (first (first string-list)) (first (first string-list)))
248        (end-string (second (first string-list)) (second (first string-list))))
249       ((null start-string))
250    (push (make-instance 'styled-string
251            :string-start start-string
252            :string-end end-string)
253          string-instances))
254  ;; Create the segment array - if styling dynamically.
255  ;; Create the inclusive string list for the segment array.
256  (setf *segment-array* (make-segment-array 
257                         (if *inc-p*
258                           (setf *segment-list* (nreverse (create-string-list start end)))
259                           (setf *segment-list* (nreverse *segment-list*)))))
260  (dolist (string string-instances)
261    (style-string string))
262  string-instances)
263
264(defun style-semi-colon-comments (&optional (start (buf-start-mark)) (end (buf-end-mark)))
265  #+sax-debug (when *style-semi-colon-comments-debug*
266                (debug-out "~%~%~S" 'style-semi-colon-comments))
267  (let ((comment-instances nil)
268        (comment-segment-list nil))
269    (do* ((start-comment (pattern-search start *semicolon-forward-pattern* end)
270                         (pattern-search end-comment *semicolon-forward-pattern* end))
271          (end-comment (when start-comment (line-end (clone start-comment)))
272                       (when start-comment (line-end (clone start-comment)))))
273         ((or (not start-comment)
274              (not end-comment)
275              (mark> start-comment end)))
276      #+sax-debug (when *style-semi-colon-comments-debug*
277                   (debug-out "~%start-comment: ~S" start-comment)
278                   (debug-out "~%end-comment: ~S" end-comment))
279
280      ;; The first AND handles the case where a string spans two comments.
281      (when (or (and (mark= start-comment (mark-line-start start-comment))
282                     (or (not *inc-p*)
283                         (and *inc-p* 
284                              (mark>= *inc-pos* start-comment)
285                              (mark<= (mark-prev *inc-pos*) end-comment))))
286                ;; with dynamically-style-comments *segment-array* may not be there yet.
287                (and (not (embedded-in-segment-p start-comment))
288                     (not (and (>= (mark-charpos start-comment) 2)
289                               (eq (mark-char start-comment -1) #\\)
290                               (eq (mark-char start-comment -2) #\#)))))
291        ;; Need the entire segment array for accurate parsing, even when
292        ;; not styling this comment:
293        (push (list start-comment end-comment) comment-segment-list)
294        (when (or (not *inc-p*)
295                  (and *inc-p* 
296                       (mark>= *inc-pos* start-comment)
297                       (mark<= (mark-prev *inc-pos*) end-comment)))
298          (push (make-instance 'styled-semi-colon-comment 
299                  :comment-start start-comment
300                  :comment-end end-comment)
301                comment-instances))))
302    (setf *segment-list* 
303          (unify-segment-lists (nreverse comment-segment-list) *segment-list*))
304    (setf *segment-array* (make-segment-array *segment-list*))
305    (setf comment-instances (nreverse comment-instances))
306    (dolist (comment comment-instances)
307      (style-comment comment))
308    comment-instances))
309
310(defun style-sharp-comments (&optional (start (buf-start-mark)) (end (buf-end-mark)))
311  (flet ((find-end-comment (start-comment)
312           (do* ((level-count 1)
313                 (next-end-comment (pattern-search start-comment *stroke-sharp-forward-pattern* end)
314                                   (when next-start-comment
315                                     (pattern-search (nmark-offset next-start-comment 2) *stroke-sharp-forward-pattern* end)))
316                 (next-start-comment (pattern-search (nmark-offset start-comment 2) *sharp-stroke-forward-pattern* end)
317                                     (when next-start-comment
318                                       (pattern-search (nmark-offset next-start-comment 2) *sharp-stroke-forward-pattern* end))))
319                ((null next-end-comment))
320             (when (and next-start-comment (mark< next-start-comment next-end-comment))
321               ;; nested
322               (incf level-count))
323             (decf level-count)
324             (when (= level-count 0) (return next-end-comment)))))
325    (let ((comment-instances nil)
326          (comment-segment-list nil))
327      (do* ((start-comment (pattern-search start *sharp-stroke-forward-pattern* end)
328                           (pattern-search end-comment *sharp-stroke-forward-pattern* end))
329            (end-comment (when (and start-comment (mark<= start-comment end)) ; *** redundant
330                           (find-end-comment start-comment))
331                         (when (and start-comment (mark<= start-comment end))
332                           (find-end-comment start-comment))))
333           ((or (not start-comment) 
334                (not end-comment)))
335        (cond ((and (not-embedded-in-segment-p *segment-array* start-comment)
336                    (not-embedded-in-segment-p *segment-array* end-comment)
337                    (or (not *inc-p*)
338                        (and *inc-p* 
339                             (mark>= *inc-pos* start-comment)
340                             (mark<= (mark-offset *inc-pos* -3) end-comment))))
341               (push (list start-comment end-comment) comment-segment-list)
342               (push (make-instance 'styled-sharp-comment 
343                       :comment-start (mark-offset start-comment -2)
344                       :comment-end (mark-offset end-comment 2))
345                     comment-instances))))
346      (when comment-instances
347        (setf *segment-list* (unify-segment-lists (nreverse comment-segment-list) *segment-list*))
348        (setf *segment-array* (make-segment-array *segment-list*))
349        (setf comment-instances (nreverse comment-instances))
350        (dolist (comment comment-instances)
351          (style-comment comment))
352        comment-instances))))
353
354(defun style-comments (start end)
355  (style-strings start end)
356  (style-semi-colon-comments start end)
357  (style-sharp-comments start end))
358
359(defun dynamically-style-comments (start end style-strings-p style-semi-colon-comments-p)
360  #+sax-debug (when *dynamically-style-comments-debug*
361                (debug-out "~%~%~S" 'dynamically-style-comments))
362  (let ((hi::*current-buffer* *buf*))
363    (hemlock::parse-over-block (mark-line start) (mark-line end))
364    (when style-strings-p (style-strings start end))
365    (when style-semi-colon-comments-p 
366      ;; (style-semi-colon-comments (mark-line-start end) end))))
367      ;; Start is necessary to generate an complete segment-array for subsequent styling:
368      (style-semi-colon-comments start end))))
369
370;;; *** this needs to use start and end
371(defun get-combined-segment-list ()
372  (let* ((start (buf-start-mark))
373         (end (buf-end-mark))
374         (string-list (nreverse (create-string-list start end)))
375         (semi-colon-comment-list (create-semi-colon-comment-list start end))
376         (sharp-stroke-comment-list (create-sharp-stroke-comment-list start end))
377         (cocoa-function-list (create-cocoa-syntax-list start end *sharp-slash-forward-pattern*))
378         (cocoa-constant1-list (create-cocoa-syntax-list start end *sharp-dollar-forward-pattern*))
379         (cocoa-constant2-list (create-cocoa-syntax-list start end *sharp-ampersand-forward-pattern*))
380         (cocoa-constant3-list (create-cocoa-syntax-list start end *colon-lessthan-forward-pattern*))
381         (cocoa-constant4-list (create-cocoa-syntax-list start end *sharp-backslash-forward-pattern*)))
382    (unify-segment-lists 
383     string-list 
384     (unify-segment-lists 
385      cocoa-constant1-list
386      (unify-segment-lists 
387       cocoa-constant2-list
388       (unify-segment-lists 
389        cocoa-constant3-list
390        (unify-segment-lists 
391         cocoa-constant4-list
392         (unify-segment-lists 
393          cocoa-function-list
394          (unify-segment-lists 
395           semi-colon-comment-list
396           sharp-stroke-comment-list)))))))))
397
398
399
400
Note: See TracBrowser for help on using the repository browser.