source: trunk/cocoa-ide-contrib/foy/syntax-styling/syntax-styling-comments.lisp @ 14985

Last change on this file since 14985 was 14985, checked in by gfoy, 9 years ago

Updates for ccl 1.7

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