source: trunk/cocoa-ide-contrib/foy/syntax-styling/syntax-styling-specials.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: 32.1 KB
Line 
1;;;-*- Mode: Lisp; Package: syntax-styling -*-
2
3;;; ****************************************************************************
4;;;
5;;;      syntax-styling-specials.lisp
6;;;
7;;;      copyright (c) 2009, 2011 Glen Foy
8;;;      (Permission is granted to Clozure Associates to distribute this file.)
9;;;
10;;;      Special variables, utility functions and macros.
11;;;
12;;;      This software is offered "as is", without warranty of any kind.
13;;;
14;;;      Mod History, most recent first:
15;;;      9/7/11    update for ccl 1.7
16;;;      10/18/9   First cut.
17;;;
18;;; ****************************************************************************
19
20#-sax-debug
21(defPackage syntax-styling (:use :cl :ccl :hemlock-internals) (:nicknames "SAX"))
22
23(in-package "SAX")
24
25;;; This is for exported symbol styling in the prefs dialog.
26(export '(common-lisp-user::pizza-to-go) :common-lisp-user)
27
28(defConstant %syntax-styling-version% "Version 0.2.1")
29
30(defVar *styling-p* t "To style or not to style.")
31(defVar *do-case-styling* t)
32(defVar *do-keyword-package* t)
33(defVar *do-exported-symbols* nil)
34(defVar *do-language-package* t)
35
36;;; These three are actually defined by defstyle.  Doing it here to muffle warnings:
37(defVar *clojure-java-style* nil)
38(defVar *vanilla-style* nil)
39(defVar *generic-text-style* nil)
40
41(defParameter *generic-symbol-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.1 0.65 1.0))
42(defParameter *generic-macro-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.5 0.1 0.2 1.0))
43
44;;; Convert style-spec to an ns-dictionary with the specified attributes.
45;;; Temporary text attributes only support color and underlining.
46(defun spec-to-dict (font-spec)
47  (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
48         (color (encoded-color-to-ns-color (getf font-spec :font-color)))
49         (underline (getf font-spec :font-underline)) ; :single :double :thick
50         (underline-int (case underline (:single 1) (:double 2) (:thick 3))))
51    (when color (#/setObject:forKey: dict color 
52                                     #&NSForegroundColorAttributeName))
53    (when (and underline underline-int) 
54      (#/setObject:forKey: dict (#/numberWithInt: ns:ns-number underline-int)
55                           #&NSUnderlineStyleAttributeName))
56    dict))
57
58(defun encoded-color-to-ns-color (color)
59  (when (integerp color)
60    (multiple-value-bind (red green blue)
61                         (color-values color)
62      (#/retain (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color red green blue 1.0)))))
63
64(defun ns-color-to-encoded-color (ns-color)
65  "Returns an encoded color from an ns-color"
66  (let ((red (truncate (* (#/redComponent ns-color) 65535)))
67        (green (truncate (* (#/greenComponent ns-color) 65535)))
68        (blue (truncate (* (#/blueComponent ns-color) 65535))))
69    (make-color red green blue)))
70
71;;; some color encoding code stolen from MCL (may she rest in peace):
72(defun make-color (red green blue)
73  "Given red, green, and blue, returns an encoded rgb value"
74  (flet ((check-color (color)
75           (unless (and (fixnump color)
76                        (<= 0 (the fixnum color))
77                        (<= (the fixnum color) 65535))
78             (error "Illegal color component: ~s" color))))
79    (declare (inline check-color))
80    (check-color red)
81    (check-color green)
82    (check-color blue))
83  (locally (declare (fixnum red green blue))
84    (let* ((r (logand red #xff00))
85           (g (logand green #xff00))
86           (b (logand blue #xff00)))
87      (declare (fixnum r g b))
88      (logior (the fixnum (ash  r 8))
89              (the fixnum g)
90              (the fixnum (ash b -8))))))
91
92(defun color-red (color &optional (component (logand (the fixnum (lsh color -16)) #xff)))
93  "Returns the red portion of the color"
94  (declare (fixnum component))
95  (the fixnum (+ (the fixnum (ash component 8)) component)))
96
97(defun color-green (color &optional (component (logand (the fixnum (lsh color -8)) #xff)))
98  "Returns the green portion of the color"
99  (declare (fixnum component))
100  (the fixnum (+ (the fixnum (ash component 8)) component)))
101
102(defun color-blue (color &optional (component (logand color #xff)))
103  "Returns the blue portion of the color"
104  (declare (fixnum component))
105  (the fixnum (+ (the fixnum (ash component 8)) component)))
106
107(defun color-values (color)
108  "Given an encoded color, returns the red, green, and blue components"
109  (values
110   (/ (float (color-red color)) (float 65535))
111   (/ (float (color-green color)) (float 65535))
112   (/ (float (color-blue color)) (float 65535))))
113
114;;; ----------------------------------------------------------------------------
115;;; Various:
116;;; ----------------------------------------------------------------------------
117;;;
118(defVar *buf* nil "The target buffer.")
119(defVar *layout* nil "The NSLayoutManager of the target text-view.")
120(defVar *current-package* nil "Package used to style exported symbols.")
121;;; consolidate these two:
122(defVar *inc-p* nil "Styling incrementally?")
123(defVar *inc-pos* nil "Buffer-point during an incremental parse.")
124(defVar *inside-semi-colon-comment-p* nil)
125(defVar *paste-p* nil "Is a paste in progress?")
126(defVar *paste-start* nil "Starting position of a paste operation.")
127(defVar *paste-end* nil "Ending position of a paste operation.")
128(defVar *prev-event* nil "The previous key-event to track control-x commands.")
129
130(defParameter *common-lisp-hash-table* (make-hash-table :test 'equal))
131(defParameter *scheme-syntax-hash-table* (make-hash-table :test 'equal))
132(defParameter *clojure-hash-table* (make-hash-table :test 'equal))
133
134(defVar *style-screen-p* t "To style or not to style the screen after a given operation.")
135(defVar *style-top-level-form-p* nil "To style or not to style the top-level form after a given operation.")
136(defVar *segment-list* nil "Comment and string code data structure.")
137(defVar *segment-array* nil "Comment and string code data structure.")
138(defVar *form-style* nil "The style of the atom being processed incrementally.")
139(defVar *form-start* nil "The start position of the atom being processed incrementally.")
140(defVar *form-end* nil "The end position of the atom being processed incrementally.")
141(defVar *superparen-closure* nil "An ugly hack to style superparens.")
142
143;;; key-event constants:
144(defConstant %control-y% #k"control-y")
145(defConstant %control-v% #k"control-v")
146(defConstant %control-x% #k"control-x")
147(defConstant %control-meta-q% #k"control-meta-q")
148(defConstant %control-e% #k"control-e")
149(defConstant %control-c% #k"control-c")
150(defConstant %control-d% #k"control-d")
151(defConstant %backspace% #k"Backspace")
152(defConstant %control-j% #k"control-j")
153(defConstant %backward-char-event% (hi::get-key-event* 98 8))
154
155;;; Search pattern constants:
156(defConstant %l-paren-forward-pattern% (new-search-pattern :character :forward #\())
157(defConstant %l-paren-backward-pattern% (new-search-pattern :character :backward #\())
158(defConstant %l-bracket-forward-pattern% (new-search-pattern :character :forward #\[))
159(defConstant %r-bracket-forward-pattern% (new-search-pattern :character :forward #\]))
160(defConstant %l-curly-brace-forward-pattern% (new-search-pattern :character :forward #\{))
161(defConstant %r-curly-brace-forward-pattern% (new-search-pattern :character :forward #\}))
162(defConstant %forward-slash-forward-pattern% (new-search-pattern :character :forward #\/))
163(defConstant %semicolon-forward-pattern% (new-search-pattern :character :forward #\;))
164(defConstant %semicolon-backward-pattern% (new-search-pattern :character :backward #\;))
165(defConstant %dot-forward-pattern% (new-search-pattern :character :forward #\.))
166(defConstant %percent-forward-pattern% (new-search-pattern :character :forward #\%))
167(defConstant %lambda-forward-pattern% (new-search-pattern :string-insensitive :forward "lambda"))
168(defConstant %sharp-stroke-forward-pattern% (new-search-pattern :string-insensitive :forward "#|"))
169(defConstant %stroke-sharp-forward-pattern% (new-search-pattern :string-insensitive :forward "|#"))
170(defConstant %sharp-slash-forward-pattern% (new-search-pattern :string-insensitive :forward "#/"))
171(defConstant %sharp-greaterthan-forward-pattern% (new-search-pattern :string-insensitive :forward "#>"))
172(defConstant %sharp-backslash-forward-pattern% (new-search-pattern :string-insensitive :forward "#\\"))
173(defConstant %sharp-dollar-forward-pattern% (new-search-pattern :string-insensitive :forward "#$"))
174(defConstant %sharp-ampersand-forward-pattern% (new-search-pattern :string-insensitive :forward "#&"))
175(defConstant %colon-lessthan-forward-pattern% (new-search-pattern :string-insensitive :forward ":<"))
176
177;;; ----------------------------------------------------------------------------
178;;; Mark functions and macros.
179;;; ----------------------------------------------------------------------------
180;;;
181;;; Hemlock's BUFFER is a doubly linked list of LINES.  MARKS specify relative positions
182;;; within LINES.  Programming Hemlock involves a lot of MARK manipulation. These are some
183;;; useful macros that operate on MARKS.  Destructive and non-destructive versions
184;;; are usually provided, using the prepended "n" convention for destructive functions.
185
186(defMacro clone (mark) `(when ,mark (hi::copy-mark ,mark :temporary)))
187
188(defMacro set-storage (storage source)
189  `(progn
190     (setf (mark-charpos ,storage) (mark-charpos ,source))
191     (setf (mark-line ,storage) (mark-line ,source))
192     ,storage))
193
194;;; Needs to support nested forms as in: (mark-next (sexpr-end pos)),
195;;; only evaluating MARK-OR-FORM once.
196;;; No error, if MARK-OR-FORM evaluates to nil, just return nil.
197(defMacro mark-next (mark-or-form)
198  (let ((param (gensym))
199        (new-mark (gensym)))
200    `(let ((,param ,mark-or-form))
201       (when ,param
202         (let ((,new-mark (clone ,param)))
203           (setq ,new-mark (mark-after ,new-mark))
204           #+sax-debug (when (and *mark-next-debug* (null ,new-mark))
205                         (debug-out "~%mark-next returning nil."))
206           ,new-mark)))))
207
208(defMacro nmark-next (mark-or-form)
209  (let ((param (gensym)))
210    `(let ((,param ,mark-or-form))
211       (when ,param (mark-after ,param)))))
212
213(defMacro mark-prev (mark-or-form)
214  (let ((param (gensym))
215        (new-mark (gensym)))
216    `(let ((,param ,mark-or-form))
217       (when ,param
218         (let ((,new-mark (clone ,param)))
219           (setq ,new-mark (mark-before ,new-mark))
220           #+sax-debug (when (and *mark-prev-debug* (null ,new-mark))
221                         (debug-out "~%mark-prev returning nil."))
222           ,new-mark)))))
223
224(defMacro nmark-prev (mark-or-form)
225  (let ((param (gensym)))
226    `(let ((,param ,mark-or-form))
227       (when ,param (mark-before ,param)))))
228
229;;; This does not cross lines
230(defMacro mark-char (mark &optional offset)
231  (if offset
232    (let ((line (gensym))
233          (line-length (gensym))
234          (mark-charpos (gensym))
235          (offset-position (gensym)))
236      `(when ,mark
237         (let* ((,line (mark-line ,mark))
238                (,line-length (line-length ,line))
239                (,mark-charpos (mark-charpos ,mark))
240                (,offset-position (+ ,mark-charpos ,offset)))
241           (cond ((and (<= 0 ,offset-position) ; offset can be negative
242                       (< ,offset-position ,line-length))
243                  (line-character ,line ,offset-position))
244                 (t
245                  nil)))))
246      `(when ,mark
247         (next-character ,mark))))
248
249(defMacro mark-move (mark pos)
250  (let ((new-mark (gensym)))
251    `(when ,mark
252       (let ((,new-mark (clone ,mark)))
253         (move-to-position ,new-mark ,pos)))))
254
255(defMacro nmark-move (mark pos)
256  `(move-to-position ,mark ,pos))
257
258(defMacro mark-line-start (mark)
259  (let ((new-mark (gensym)))
260    `(when ,mark 
261       (let ((,new-mark (clone ,mark)))
262         (line-start ,new-mark)))))
263
264(defMacro mark-offset (mark offset)
265  (let ((new-mark (gensym)))
266    `(when ,mark
267       (let ((,new-mark (clone ,mark)))
268         (character-offset ,new-mark ,offset)))))
269
270(defMacro nmark-offset (mark offset)
271  `(when ,mark
272     (character-offset ,mark ,offset)
273     ,mark))
274
275(defMacro mark-min (m1 m2) `(if (mark< ,m1 ,m2) ,m1 ,m2))
276
277(defMacro mark-max (m1 m2) `(if (mark> ,m1 ,m2) ,m1 ,m2))
278
279(defMacro buf-end-mark (&optional buffer) 
280  `(clone (buffer-end-mark (if ,buffer ,buffer *buf*))))
281
282(defMacro buf-start-mark (&optional buffer) 
283  `(clone (buffer-start-mark (if ,buffer ,buffer *buf*))))
284
285;;; ----------------------------------------------------------------------------
286;;; Buffer functions and macros.
287;;; ----------------------------------------------------------------------------
288;;;
289(defMacro buffer-empty-p () `(mark= (buffer-start-mark *buf*) (buffer-end-mark *buf*)))
290
291(defun buffer-line-start (buffer &optional storage)
292  (let ((line (mark-line (buffer-point buffer))))
293    (cond (storage
294           (setf (mark-line storage) line)
295           (setf (mark-charpos storage) 0)
296           storage)
297          (
298           (mark line 0)))))
299
300(defun buffer-line-end (buffer &optional storage)
301  (let ((line (mark-line (buffer-point buffer))))
302    (cond (storage
303           (setf (mark-line storage) line)
304           (setf (mark-charpos storage) (line-length line)))
305          (t
306           (mark line (line-length line))))))
307
308;;; ----------------------------------------------------------------------------
309;;; Lisp syntax functions and macros.
310;;; ----------------------------------------------------------------------------
311;;;
312(defMacro sexpr-end (start)
313    (let ((sexpr-start (gensym))
314          (sexpr-end (gensym)))
315      `(when ,start
316         (let* ((,sexpr-start (clone ,start))
317                (,sexpr-end (when (hemlock::form-offset ,sexpr-start 1) ,sexpr-start)))
318           (if ,sexpr-end
319             ,sexpr-end
320             #+sax-debug (when *sexpr-end-debug* 
321                             (debug-out "~%sexpr-end returning nil - start-mark: ~S" ,start)))))))
322
323(defMacro sexpr-start (pos)
324  (let ((sexpr-start (gensym)))
325    `(when ,pos
326       (let ((,sexpr-start (clone ,pos)))
327         (if (hemlock::form-offset ,sexpr-start -1) 
328           ,sexpr-start
329           #+sax-debug (when *sexpr-start-debug* 
330                         (debug-out "~%sexpr-start returning nil - pos-mark: ~S" ,pos)))))))
331
332(defMacro limited-sexpr-end (start limit)
333  (let ((sexpr-start (gensym))
334        (sexpr-end (gensym))) 
335    `(when ,start
336       #+sax-debug (when *limited-sexpr-end-debug* 
337                     (debug-out "~%~%~S" 'limited-sexpr-end)
338                     (debug-out "~%start: ~S" ,start)
339                     (debug-out "~%limit: ~S" ,limit))
340       (let* ((,sexpr-start (clone ,start))
341              (,sexpr-end (when (hemlock::form-offset ,sexpr-start 1) ,sexpr-start)))
342         #+sax-debug (when *limited-sexpr-end-debug*
343                       (debug-out "~%sexpr-end: ~S" ,sexpr-end))
344         (if ,sexpr-end
345           (when (mark<= ,sexpr-end ,limit) ,sexpr-end)
346           #+sax-debug (when *limited-sexpr-end-debug* 
347                         (debug-out "~%limited-sexpr-end returning nil - start-mark: ~S" ,start)))))))
348
349(defMacro next-sexpr-start (mark)
350  (let ((position (gensym))
351        (previous-position (gensym))
352        (forward (gensym))
353        (start (gensym))
354        (param (gensym)))
355    `(let ((,param (clone ,mark))
356           (,previous-position nil))
357       (when ,param
358         #+sax-debug (when *next-sexpr-start-debug*
359                       (debug-out "~%~%~S" 'next-sexpr-start)
360                       (debug-out "~%next-sexpr-start mark: ~S" ,mark))
361         (do* ((,position (clone ,param) (clone ,param))
362               (,forward (cond ((hemlock::form-offset ,position 1) 
363                                #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%do: forward: ~S" ,position))
364                                ,position)
365                               (t
366                                #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%do: (form-offset position 1) failed"))
367                                nil))
368                         (cond ((hemlock::form-offset ,position 1) 
369                                #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%do: forward: ~S" ,position))
370                                ,position)
371                               (t
372                                #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%do: (form-offset position 1) failed"))
373                               nil)))
374               (,start (when ,forward (when (hemlock::form-offset ,forward -1) 
375                                        #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%do: start: ~S" ,forward))
376                                        ,forward))
377                       (when ,forward (when (hemlock::form-offset ,forward -1) 
378                                        #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%do: start: ~S" ,forward))
379                                        ,forward))))
380              ((or (null ,start) (mark>= ,start ,mark))
381               #+sax-debug (when *next-sexpr-start-debug*
382                             (debug-out "~%forward: ~S" ,forward)
383                             (debug-out "~%start: ~S" ,start))
384               #+sax-debug (when (and *next-sexpr-start-debug* (null ,start)) (debug-out "~%next-sexpr-start returning nil"))
385               (if *inc-p*
386                 (when (and ,start (mark< ,start *inc-pos*))
387                   ,start)
388                 ,start))
389           (hemlock::form-offset ,param 1)
390           #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%(form-offset param 1): ~S" ,param))
391
392           ;; This COND is a kludge to compensate for what appears to be a bug in hemlock::form-offset.
393           ;; When there is a semicolon comment directly after a form like so:
394           ;;      (pushnew 'foo list);offending comment
395           ;; form-offset does not go to the next form. If the comment has a space:
396           ;;      (pushnew 'foo list) ;comment with space
397           ;; things work as advertised. 7-15-11
398           (cond ((null ,param) (return nil))
399                 ((null ,previous-position)
400                  #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%setting previous-position: ~S" ,param))
401                  (setq ,previous-position (clone ,param)))
402                 ((mark= ,previous-position ,param) ; avoiding an endless loop is good ...
403                  #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%repeated position: ~S, doing form-offset again." ,param))
404                  (setq ,previous-position nil)
405                  (hemlock::form-offset ,param 1)
406                  #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%form-offset again: ~S" ,param)))
407                 (t
408                  (setq ,previous-position (clone ,param)))))))))
409
410(defMacro nnext-sexpr-start (mark-or-form)
411  (let ((position (gensym))
412        (forward (gensym))
413        (start (gensym))
414        (param (gensym)))
415    `(let ((,param ,mark-or-form))
416       (when ,param
417         #+sax-debug (when *nnext-sexpr-start-debug*
418                       (debug-out "~%~%~S"'nnext-sexpr-start)
419                       (debug-out "~%mark-or-form: ~S" ,mark-or-form)
420                       (debug-out "~%param: ~S" ,param))
421         (let* ((,position ,param)
422                (,forward (when (hemlock::form-offset ,position 1) ,position))
423                (,start (when ,forward (when (hemlock::form-offset ,forward -1) ,forward))))
424           #+sax-debug (when *nnext-sexpr-start-debug* 
425                        (if (null ,start)
426                          (debug-out "~%nnext-sexpr-start returning nil")
427                          (debug-out "~%nnext-sexpr-start returning: ~S" ,start)))
428           (if *inc-p*
429             (when (and ,start (mark< ,start *inc-pos*))
430               ,start)
431             ,start))))))
432
433(defMacro atom-start (start)
434  (let ((pos (gensym))
435        (char (gensym))
436        (buf-start (gensym)))
437    `(when ,start
438       (let ((,buf-start (buf-start-mark *buf*)))
439         (do* ((,pos ,start (mark-before ,pos))
440               (,char (when (and ,pos (mark>= ,pos ,buf-start))
441                        (mark-char ,pos))
442                      (when (and ,pos (mark>= ,pos ,buf-start))
443                        (mark-char ,pos))))
444              ((or (null ,char) ; ***
445                   (whitespacep ,char) (char= ,char #\() 
446                   (char= ,char #\)) (char= ,char #\"))
447               (if ,pos (mark-after ,pos) ,buf-start)))))))
448
449(defMacro atom-end (s)
450  (let ((start (gensym))
451        (buffer-end-mark (gensym))
452        (pos (gensym))
453        (char (gensym)))
454    `(when ,s
455       (let ((,start (clone ,s))
456             (,buffer-end-mark (buffer-end-mark *buf*)))
457         (do* ((,pos ,start (mark-after ,pos))
458               (,char (when (mark<= ,pos ,buffer-end-mark) (mark-char ,pos))
459                      (when (mark<= ,pos ,buffer-end-mark) (mark-char ,pos))))
460              ((or (null ,char) ; ***
461                   (whitespacep ,char) (char= ,char #\)) (char= ,char #\() 
462                   (char= ,char #\") (char= ,char #\;)) 
463               ,pos))))))
464
465(defun buffer-top-level-sexpr-start (buffer &optional storage)
466  (cond (storage
467         (set-storage storage (buffer-point buffer))
468         (hemlock::top-level-offset storage -1))
469        (t
470         (let ((mark (clone (buffer-point buffer))))
471           (hemlock::top-level-offset mark -1)))))
472
473(defun buffer-top-level-sexpr-end (buffer &optional storage)
474  (cond (storage
475         (set-storage storage (buffer-point buffer))
476         (hemlock::top-level-offset storage 1))
477        (t
478         (let ((mark (clone (buffer-point buffer))))
479           (hemlock::top-level-offset mark 1)))))
480
481
482;;; ----------------------------------------------------------------------------
483;;; Miscellaneous functions and macros.
484;;; ----------------------------------------------------------------------------
485;;;
486(defun pattern-search (mark pattern &optional end)
487  (with-mark ((m mark))
488    (if end 
489      (when (and (find-pattern m pattern) (mark< m end)) m)
490      (when (find-pattern m pattern) m))))
491
492(defun language-string-style ()
493  (cond ((lisp-file-p) (string-style))
494        ((scheme-file-p) (scheme-string-style))
495        ((clojure-file-p) (clojure-string-style))))
496
497(defun language-documentation-style ()
498  (cond ((lisp-file-p) (documentation-style))
499        ;;; ***
500        ((scheme-file-p) (documentation-style))
501        ((clojure-file-p) (clojure-documentation-style))))
502
503(defun language-generic-text-style ()
504  (cond ((lisp-file-p) (generic-text-style))
505        ((scheme-file-p) (scheme-generic-text-style))
506        ((clojure-file-p) (clojure-generic-text-style))))
507
508(defun language-semi-colon-comment-style ()
509  (cond ((lisp-file-p) (semi-colon-comment-style))
510        ((scheme-file-p) (scheme-semi-colon-comment-style))
511        ((clojure-file-p) (clojure-semi-colon-comment-style))))
512
513(defun language-sharp-comment-style ()
514  (cond ((lisp-file-p) (sharp-comment-style))
515        ((scheme-file-p) (scheme-sharp-comment-style))))
516
517(defun language-keyword-style ()
518  (cond ((lisp-file-p) (keyword-package-style))
519        ((clojure-file-p) (clojure-keyword-style))))
520
521#|
522;;; (buffer-writable buffer) is broken
523(defun writable-p (thing)
524  (declare (ignore thing))
525  t)
526
527(defun writable-path-p (path)
528  (let* ((file-manager (#/defaultManager ns:ns-file-manager))
529         (path (ccl::%make-nsstring path)))
530    (#/isWritableFileAtPath: file-manager path)))
531
532(defMethod writable-p ((hemlock-view hi::hemlock-view))
533  (let ((buffer (hemlock-view-buffer hemlock-view)))
534    (or (not *do-case-styling*)
535        (format t "~%view-writable-p: ~S" (buffer-writable buffer))
536        ;; *** broken
537        (buffer-writable buffer))))
538
539(defMethod writable-p ((text-view gui::hemlock-textstorage-text-view))
540  (let* ((hemlock-view (gui::hemlock-view text-view))
541         (buffer (hemlock-view-buffer hemlock-view)))
542    (or (not *do-case-styling*)
543        (format t "~%writable-p: ~S" (buffer-writable buffer))
544        (buffer-writable buffer))))
545
546(defMethod writable-p ((window gui::hemlock-frame))
547  (let* ((hemlock-view (gui::hemlock-view window))
548         (buffer (hemlock-view-buffer hemlock-view)))
549    (or (not *do-case-styling*)
550        (format t "~%writable-p: ~S" (buffer-writable buffer))
551        (buffer-writable buffer))))
552|#
553
554(defun active-hemlock-window ()
555  "Return the active hemlock-frame."
556  (gui::first-window-satisfying-predicate 
557   #'(lambda (w)
558       (and (typep w 'gui::hemlock-frame)
559            (not (typep w 'gui::hemlock-listener-frame))
560            (#/isKeyWindow w)))))
561
562(defun window-path (w)
563  "Return the window's path."
564  (let* ((pane (slot-value w 'gui::pane))
565         (hemlock-view (when pane (gui::text-pane-hemlock-view pane)))
566         (buffer (when hemlock-view (hi::hemlock-view-buffer hemlock-view))))
567    (when buffer (hi::buffer-pathname buffer))))
568
569(defMacro char-eolp (char) 
570  `(member ,char '(#\return #\linefeed #\newline ,(code-char #x2028) ,(code-char #x2029))))
571
572(defun ed-beep () ())
573;;; (#_nsbeep))
574
575(define-symbol-macro *listener-output* (hemlock-ext::top-listener-output-stream))
576
577(defun listener-msg (string &rest args)
578  (apply 'format *listener-output* string args))
579
580(defun selection-marks (text-view)
581  (let ((selection (#/selectedRange text-view))
582        start end)
583    (when selection
584      (let ((length (ns:ns-range-length selection))
585            (location (ns:ns-range-location selection)))
586        (unless (zerop length)
587          (setf start (move-to-absolute-position (buf-start-mark) location))
588          (setf end (character-offset (clone start) length)))))
589    (values start end)))
590
591(defun key-event= (k1 k2)
592  (and (= (hi::key-event-keysym k1) (hi::key-event-keysym k2))
593       (= (hi::key-event-bits k1) (hi::key-event-bits k2))))
594
595(defMethod hemlock-update ((view hi:hemlock-view) start end &optional count)
596  (let* ((buffer (hemlock-view-buffer view))
597         (document (hi::buffer-document buffer))
598         (text-storage (if document (slot-value document 'gui::textstorage)))
599         (location (mark-absolute-position start))
600         (length (or count (- (mark-absolute-position end) location))))
601    #+sax-debug (when *hemlock-update-debug*
602                   (debug-out "~%~%~S" 'hemlock-update)
603                   (debug-out "~%start: ~S" start)
604                   (debug-out "~%end: ~S" end)
605                   (debug-out "~%location: ~S" location)
606                   (debug-out "~%length: ~S" length))
607    ;;; 0 is the fontnum
608    (gui::perform-edit-change-notification 
609     text-storage
610     (objc:@selector #/noteHemlockAttrChangeAtPosition:length:fontNum:)
611     location length 0)))
612
613(defMethod hemlock-update ((frame gui::hemlock-frame) start end &optional count)
614  (let ((hemlock-view (gui::hemlock-view frame)))
615    (hemlock-update hemlock-view start end count)))
616
617(defMacro attribute-dictionary (var) `(car ,var)) 
618
619(defMacro style-case (var) `(cdr ,var))
620
621(defun set-style-attributes (dictionary &optional (start (buf-start-mark))
622                                        (end (buf-end-mark)))
623  #+sax-debug (when *set-style-attributes-debug* 
624                (debug-out "~%~%~S" 'set-style-attributes)
625                (debug-out "~%dictionary: ~S" dictionary)
626                (debug-out "~%start: ~S" start)
627                (debug-out "~%end: ~S" end))
628  (when (and start end)
629    (ns:with-ns-range (range)
630      (let* ((location (mark-absolute-position start))
631             (length (- (mark-absolute-position end) location)))
632        (setf (ns:ns-range-location range) location)
633        (setf (ns:ns-range-length range) length)
634        ;; Remove all temporary attributes from the character range
635        (#/removeTemporaryAttribute:forCharacterRange:
636         *layout* #&NSForegroundColorAttributeName range)
637        (#/removeTemporaryAttribute:forCharacterRange:
638         *layout* #&NSUnderlineStyleAttributeName range)
639        (#/addTemporaryAttributes:forCharacterRange: *layout* dictionary range)))))
640
641(defun set-generic-text-style (text-view &optional (start (buf-start-mark)) (end (buf-end-mark)))
642  ;; eliminate paren highlighting:
643  (let* ((begin (mark-absolute-position start))
644         (count (- (mark-absolute-position end) begin)))
645    (when (and begin count)
646      (ns:with-ns-range  (char-range begin count)
647        (let* ((layout (#/layoutManager text-view)))
648          (#/removeTemporaryAttribute:forCharacterRange: 
649           layout #&NSBackgroundColorAttributeName 
650           char-range)))))
651  (set-style-attributes  (attribute-dictionary (language-generic-text-style)) start end))
652
653(defun downcase-region (start end)
654  ;; downcases all nonescaped characters in region
655  (filter-region #'string-downcase (region start end)))
656
657(defun upcase-region (start end)
658  (filter-region #'string-upcase (region start end)))
659
660(defun capitalize-region (start end)
661  (filter-region #'string-capitalize (region start end)))
662
663(defMethod set-style-case ((case (eql :down)) start end)
664  (downcase-region start end))
665
666(defMethod set-style-case ((case (eql :up)) start end)
667  ;; don't use eupcase region...
668  (upcase-region start end))
669
670(defMethod set-style-case ((case (eql :unchanged)) start end)
671  (declare (ignore start end)) ())
672
673(defMethod set-style-case ((case (eql :cap)) start end)
674  (capitalize-region start end))
675
676(defMethod set-style-case ((case (eql :cap3)) start end)
677  (set-style-case :down start end)
678  (capitalize-region (mark-offset start 3) (mark-offset start 4)))
679
680(defMethod set-style-case ((case (eql :cap03)) start end)
681  (set-style-case :down start end)
682  (capitalize-region start end)
683  (capitalize-region (mark-offset start 3) (mark-offset start 4)))
684
685(defMethod set-style-case ((case (eql :cap8)) start end)
686  (set-style-case :down start end)
687  (capitalize-region (mark-offset start 8) (mark-offset start 9)))
688
689;;; *** hemlock::defCommand
690(defMethod set-style-case ((case (eql :cap12)) start end)
691  (set-style-case :down start end)
692  (capitalize-region (mark-offset start 12) (mark-offset start 13)))
693
694(defMacro style-region (style start end  &optional (set-case-p t))
695  "This is the basic styling macro that calls SET-STYLE-ATTRIBUTES and SET-STYLE-CASE."
696  `(progn
697     #+sax-debug (when *style-region-debug* 
698                  (debug-out "~%~%~S" 'style-region)
699                  (debug-out "~%start: ~S" ,start)
700                  (debug-out "~%end: ~S" ,end)
701                  (debug-out "~%style: ~S" ,style)
702                  (debug-out "~%set-case-p: ~S" ,set-case-p)
703                  (debug-out "~%*paste-p*: ~S" *paste-p*)
704                  (debug-out "~%*paste-start*: ~S" *paste-start*)
705                  (debug-out "~%*paste-end*: ~S" *paste-end*)
706                  (debug-out "~%*inc-p*: ~S" *inc-p*)
707                  (debug-out "~%*inc-pos*: ~S" *inc-pos*))
708     (when (or (and *inc-p* (not *paste-p*)
709                    (mark>= *inc-pos* ,start)
710                    ;; mark-next to accommodate styling after a space char
711                    (mark<= *inc-pos* (mark-next ,end)))
712               (not *inc-p*)
713               (and *paste-p*
714                    (mark>= ,start *paste-start*)
715                    (mark<= ,end *paste-end*)))
716
717       (when (and *do-case-styling* ,set-case-p (style-case ,style))
718         #+sax-debug (when *style-region-debug*
719                      (debug-out "~%set-style-case, case: ~S" (style-case ,style))
720                      (debug-out "~%set-style-case, region: ~S" (region ,start ,end)))
721           (set-style-case (style-case ,style) ,start ,end))
722
723       (cond ((and *inc-p* (not *paste-p*))
724              ;; Don't set attributes when doing incremental. We are
725              ;; inside #/beginEditing, #/endEditing.  Save the values.
726              #+sax-debug (when *style-region-debug* 
727                            (debug-out "~%~%*** setting *form-style* for: ~S ***" 
728                                       (region-to-string (region ,start ,end))))
729              (setq *form-style* ,style
730                    *form-start* ,start
731                    *form-end* ,end))
732             (t
733              #+sax-debug (when *style-region-debug*
734                            (if (or (equalp ,style *generic-text-style*)
735                                    (equalp ,style *scheme-generic-text-style*)
736                                    (equalp ,style *clojure-generic-text-style*))
737                              (debug-out "~%*** styling-region-generically: ~S ***"
738                                         (region-to-string (region ,start ,end)))
739                              (debug-out "~%*** styling-region: ~S ***"
740                                         (region-to-string (region ,start ,end))))
741                            (debug-out "~%style: ~S" ,style))
742              (set-style-attributes (attribute-dictionary ,style) ,start ,end))))))
743
744 
745
746
Note: See TracBrowser for help on using the repository browser.