source: trunk/source/contrib/foy/syntax-styling/syntax-styling-specials.lisp @ 13041

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

Set *style-case-p* to t.

File size: 31.7 KB
Line 
1;;;-*- Mode: Lisp; Package: SYNTAX-STYLING -*-
2
3;;; ****************************************************************************
4;;;
5;;;      syntax-styling-specials.lisp
6;;;
7;;;      copyright (c) 2009 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;;;      10/18/9   First cut.
16;;;
17;;; ****************************************************************************
18
19#-sax-debug
20(defPackage syntax-styling (:use :cl :ccl :hemlock-internals) (:nicknames "SAX"))
21
22(in-package "SAX")
23
24(defParameter *style-case-p* t "To set case, or not to set case.")
25
26;;; ----------------------------------------------------------------------------
27;;; Configure your style by hacking the colors and style parameters below:
28;;; ----------------------------------------------------------------------------
29;;;
30(defParameter *black-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.0 0.0 1.0))
31(defParameter *gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.92 0.92 0.92 1.0))
32(defParameter *medium-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.30 0.30 0.30 1.0))
33(defParameter *darker-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.11 0.11 0.11 1.0))
34(defParameter *dark-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.01 0.01 0.01 1.0))
35(defParameter *blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.1 0.65 1.0))
36(defParameter *light-blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.35 0.65 1.0))
37(defParameter *green-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.2 0.0 1.0))
38(defParameter *turquoise-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.3 0.4 1.0))
39(defParameter *violet-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.15 0.1 0.7 1.0))
40(defParameter *wine-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.5 0.1 0.2 1.0))
41(defParameter *medium-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.8 0.0 0.2 1.0))
42(defParameter *magenta-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.75 0.0 0.5 1.0))
43(defParameter *dark-magenta-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.35 0.0 0.25 1.0))
44(defParameter *brown-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.35 0.2 0.0 1.0))
45
46(defParameter *generic-symbol-color* *blue-color*)
47(defParameter *generic-macro-color* *wine-red-color*)
48
49;;; Convert style-spec to an ns-dictionary with the specified attributes.
50;;; Temporary text attributes only support color and underlining.
51(defun spec-to-dict (font-spec)
52  (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
53         (color (getf font-spec :font-color)) 
54         (underline (getf font-spec :font-underline)) ; :single :double :thick
55         (underline-int (case underline (:single 1) (:double 2) (:thick 3))))
56    (when color (#/setObject:forKey: dict color 
57                                     #&NSForegroundColorAttributeName))
58    (when (and underline underline-int) 
59      (#/setObject:forKey: dict (#/numberWithInt: ns:ns-number underline-int)
60                           #&NSUnderlineStyleAttributeName))
61    dict))
62
63;;; ----------------------------------------------------------------------------
64;;; The Styles:
65;;; ----------------------------------------------------------------------------
66;;;
67;;; The cdr of each dotted-pair is the capitalization spec:
68(defParameter *vanilla-styling* (cons (spec-to-dict (list :font-color *black-color*)) :down))
69(defParameter *generic-text-style* (cons (spec-to-dict (list :font-color *darker-gray-color*)) :down))
70(defParameter *generic-macro-style* (cons (spec-to-dict (list :font-color *generic-macro-color*)) :cap3))
71(defParameter *generic-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down))
72(defParameter *generic-function-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down)) 
73(defParameter *embedded-function-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down)) 
74;;; This is also the style for lambda-list keywords:
75(defParameter *keyword-package-style* (cons (spec-to-dict (list :font-color *dark-magenta-color*)) :down))
76(defParameter *cl-package-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down))
77(defParameter *exported-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :double)) :up))
78
79(defParameter *semi-colon-comment-style* (cons (spec-to-dict (list :font-color *turquoise-color*)) :unchanged))
80(defParameter *sharp-comment-style* (cons (spec-to-dict (list :font-color *medium-gray-color*)) :unchanged))
81(defParameter *string-style* (cons (spec-to-dict (list :font-color *turquoise-color*)) :unchanged))
82
83(defParameter *superparen-style* (cons (spec-to-dict (list :font-color *magenta-color*)) :unchanged))
84(defParameter *eval-when-superparen-style* (cons (spec-to-dict (list :font-color *magenta-color*)) :unchanged))
85(defParameter *loop-superparen-style* (cons (spec-to-dict (list :font-color *turquoise-color*)) :unchanged))
86
87(defParameter *variable-definition-symbol-style* (cons (spec-to-dict (list :font-color *light-blue-color*)) :down))
88(defParameter *defstruct-field-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down))
89(defParameter *defstruct-ancestor-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down))
90(defParameter *defclass-derivation-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down))
91(defParameter *defclass-slot-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down))
92(defParameter *parameter-style* (cons (spec-to-dict (list :font-color *light-blue-color*)) :down))
93(defParameter *specializer-style* (cons (spec-to-dict (list :font-color *green-color*)) :unchanged))
94(defParameter *case-match-style* (cons (spec-to-dict (list :font-color *light-blue-color*)) :down))
95
96(defParameter *defpackage-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down))
97(defParameter *defparameter-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down))
98(defParameter *defvar-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down))
99(defParameter *defconstant-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down))
100(defParameter *defclass-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :up))
101(defParameter *defun-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down))
102(defParameter *defmacro-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down))
103(defParameter *defgeneric-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down))
104(defParameter *defmethod-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down))
105(defParameter *objc-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :unchanged))
106(defParameter *defcommand-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :unchanged))
107(defParameter *defstruct-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :up))
108
109(defParameter *lambda-macro-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down))
110(defParameter *loop-macro-style* (cons (spec-to-dict (list :font-color *magenta-color*)) :up))
111(defParameter *loop-keyword-style* (cons (spec-to-dict (list :font-color *dark-magenta-color*)) :down))
112(defParameter *defun-macro-style* (cons (spec-to-dict (list :font-color *generic-macro-color*)) :down))
113(defParameter *objc-macro-style* (cons (spec-to-dict (list :font-color *generic-macro-color*)) :cap8))
114(defParameter *defcommand-macro-style* (cons (spec-to-dict (list :font-color *generic-macro-color*)) :cap12))
115
116;;; ----------------------------------------------------------------------------
117;;; Various:
118;;; ----------------------------------------------------------------------------
119;;;
120(defParameter *styling-p* t "To style or not to style.")
121(defParameter *buf* nil "The target buffer.")
122(defParameter *layout* nil "The NSLayoutManager of the target text-view.")
123(defParameter *current-package* nil "Package used to style exported symbols.")
124;;; consolidate these two:
125(defParameter *inc-p* nil "Styling incrementally?")
126(defParameter *inc-pos* nil "Buffer-point during an incremental parse.")
127(defParameter *inside-semi-colon-comment-p* nil)
128(defParameter *paste-p* nil "Is a paste in progress?")
129(defParameter *paste-start* nil "Starting position of a paste operation.")
130(defParameter *paste-end* nil "Ending position of a paste operation.")
131
132;;; test
133(defParameter *style-screen-p* t "To style or not to style the screen after a given operation.")
134(defParameter *style-top-level-form-p* nil "To style or not to style the top-level form after a given operation.")
135(defParameter *segment-list* nil "Comment and string code data structure.")
136(defParameter *segment-array* nil "Comment and string code data structure.")
137
138(defParameter *form-style* nil "The style of the atom being processed incrementally.")
139(defParameter *form-start* nil "The start position of the atom being processed incrementally.")
140(defParameter *form-end* nil "The end position of the atom being processed incrementally.")
141(defParameter *superparen-closure* nil "An ugly hack to style superparens.")
142
143;;; key-event constants:
144(defParameter %control-y% #k"control-y")
145(defParameter %control-meta-q% #k"control-meta-q")
146(defParameter %control-d% #k"control-d")
147(defParameter %backspace% #k"Backspace")
148(defParameter %control-j% #k"control-j")
149(defparameter %backward-char-event% (hi::get-key-event* 98 8))
150
151;;; Search patterns:
152(defparameter *l-paren-forward-pattern* (new-search-pattern :character :forward #\())
153(defparameter *l-paren-backward-pattern* (new-search-pattern :character :backward #\())
154(defparameter *sharp-stroke-forward-pattern* (new-search-pattern :string-insensitive :forward "#|"))
155(defparameter *stroke-sharp-forward-pattern* (new-search-pattern :string-insensitive :forward "|#"))
156(defparameter *semicolon-forward-pattern* (new-search-pattern :character :forward #\;))
157(defParameter *sharp-slash-forward-pattern* (new-search-pattern :string-insensitive :forward "#/"))
158(defParameter *sharp-backslash-forward-pattern* (new-search-pattern :string-insensitive :forward "#\\"))
159(defParameter *sharp-dollar-forward-pattern* (new-search-pattern :string-insensitive :forward "#$"))
160(defParameter *sharp-ampersand-forward-pattern* (new-search-pattern :string-insensitive :forward "#&"))
161(defParameter *colon-lessthan-forward-pattern* (new-search-pattern :string-insensitive :forward ":<"))
162
163;;; ----------------------------------------------------------------------------
164;;; Mark functions and macros.
165;;; ----------------------------------------------------------------------------
166;;;
167;;; Hemlock's BUFFER is a doubly linked list of LINES.  MARKS specify relative positions
168;;; within LINES.  Programming Hemlock involves a lot of MARK manipulation. These are some
169;;; useful macros that operate on MARKS.  Destructive and non-destructive versions
170;;; are usually provided, using the prepended "n" convention for destructive functions.
171
172(defmacro clone (mark) `(hi::copy-mark ,mark :temporary))
173
174(defmacro set-storage (storage source)
175  `(progn
176     (setf (mark-charpos ,storage) (mark-charpos ,source))
177     (setf (mark-line ,storage) (mark-line ,source))
178     ,storage))
179
180;;; Needs to support nested forms as in: (mark-next (sexpr-end pos)),
181;;; only evaluating MARK-OR-FORM once.
182;;; No error, if MARK-OR-FORM evaluates to nil, just return nil.
183(defmacro mark-next (mark-or-form)
184  (let ((param (gensym))
185        (new-mark (gensym)))
186    `(let ((,param ,mark-or-form))
187       (when ,param
188         (let ((,new-mark (clone ,param)))
189           (setq ,new-mark (mark-after ,new-mark))
190           #+sax-debug (when (and *mark-next-debug* (null ,new-mark))
191                         (debug-out "~%mark-next returning nil."))
192           ,new-mark)))))
193
194(defmacro nmark-next (mark-or-form)
195  (let ((param (gensym)))
196    `(let ((,param ,mark-or-form))
197       (when ,param (mark-after ,param)))))
198
199(defmacro mark-prev (mark-or-form)
200  (let ((param (gensym))
201        (new-mark (gensym)))
202    `(let ((,param ,mark-or-form))
203       (when ,param
204         (let ((,new-mark (clone ,param)))
205           (setq ,new-mark (mark-before ,new-mark))
206           #+sax-debug (when (and *mark-prev-debug* (null ,new-mark))
207                         (debug-out "~%mark-prev returning nil."))
208           ,new-mark)))))
209
210(defmacro nmark-prev (mark-or-form)
211  (let ((param (gensym)))
212    `(let ((,param ,mark-or-form))
213       (when ,param (mark-before ,param)))))
214
215;;; This does not cross lines
216(defmacro mark-char (mark &optional offset)
217  (if offset
218    (let ((line (gensym))
219          (line-length (gensym))
220          (mark-charpos (gensym))
221          (offset-position (gensym)))
222      `(when ,mark
223         (let* ((,line (mark-line ,mark))
224                (,line-length (line-length ,line))
225                (,mark-charpos (mark-charpos ,mark))
226                (,offset-position (+ ,mark-charpos ,offset)))
227           (cond ((and (<= 0 ,offset-position) ; offset can be negative
228                       (< ,offset-position ,line-length))
229                  (line-character ,line ,offset-position))
230                 (t
231                  nil)))))
232      `(when ,mark
233         (next-character ,mark))))
234
235(defmacro mark-move (mark pos)
236  (let ((new-mark (gensym)))
237    `(when ,mark
238       (let ((,new-mark (clone ,mark)))
239         (move-to-position ,new-mark ,pos)))))
240
241(defmacro nmark-move (mark pos)
242  `(move-to-position ,mark ,pos))
243
244(defmacro mark-line-start (mark)
245  (let ((new-mark (gensym)))
246    `(when ,mark 
247       (let ((,new-mark (clone ,mark)))
248         (line-start ,new-mark)))))
249
250(defmacro mark-offset (mark offset)
251  (let ((new-mark (gensym)))
252    `(when ,mark
253       (let ((,new-mark (clone ,mark)))
254         (character-offset ,new-mark ,offset)))))
255
256(defmacro nmark-offset (mark offset)
257  `(when ,mark
258     (character-offset ,mark ,offset)
259     ,mark))
260
261(defMacro mark-min (m1 m2) `(if (mark< ,m1 ,m2) ,m1 ,m2))
262
263(defMacro mark-max (m1 m2) `(if (mark> ,m1 ,m2) ,m1 ,m2))
264
265(defmacro buf-end-mark (&optional buffer) 
266  `(clone (buffer-end-mark (if ,buffer ,buffer *buf*))))
267
268(defmacro buf-start-mark (&optional buffer) 
269  `(clone (buffer-start-mark (if ,buffer ,buffer *buf*))))
270
271;;; ----------------------------------------------------------------------------
272;;; Buffer functions and macros.
273;;; ----------------------------------------------------------------------------
274;;;
275(defmacro buffer-empty-p () `(mark= (buffer-start-mark *buf*) (buffer-end-mark *buf*)))
276
277(defun buffer-line-start (buffer &optional storage)
278  (let ((line (mark-line (buffer-point buffer))))
279    (cond (storage
280           (setf (mark-line storage) line)
281           (setf (mark-charpos storage) 0)
282           storage)
283          (
284           (mark line 0)))))
285
286(defun buffer-line-end (buffer &optional storage)
287  (let ((line (mark-line (buffer-point buffer))))
288    (cond (storage
289           (setf (mark-line storage) line)
290           (setf (mark-charpos storage) (line-length line)))
291          (t
292           (mark line (line-length line))))))
293
294;;; ----------------------------------------------------------------------------
295;;; Lisp syntax functions and macros.
296;;; ----------------------------------------------------------------------------
297;;;
298(defmacro sexpr-end (start)
299    (let ((sexpr-start (gensym))
300          (sexpr-end (gensym)))
301      `(when ,start
302         (let* ((,sexpr-start (clone ,start))
303                (,sexpr-end (when (hemlock::form-offset ,sexpr-start 1) ,sexpr-start)))
304           (if ,sexpr-end
305             ,sexpr-end
306             #+sax-debug (when *sexpr-end-debug* 
307                           (debug-out "~%sexpr-end returning nil - start-mark: ~S" ,start)))))))
308
309(defmacro sexpr-start (pos)
310  (let ((sexpr-start (gensym)))
311    `(when ,pos
312       (let ((,sexpr-start (clone ,pos)))
313         (if (hemlock::form-offset ,sexpr-start -1) 
314           ,sexpr-start
315           #+sax-debug (when *sexpr-start-debug* 
316                         (debug-out "~%sexpr-start returning nil - pos-mark: ~S" ,pos)))))))
317
318(defmacro limited-sexpr-end (start limit)
319  (let ((sexpr-start (gensym))
320        (sexpr-end (gensym))) 
321    `(when ,start
322       #+sax-debug (when *limited-sexpr-end-debug* 
323                     (debug-out "~%~%~S" 'limited-sexpr-end)
324                     (debug-out "~%start: ~S" ,start)
325                     (debug-out "~%limit: ~S" ,limit))
326       (let* ((,sexpr-start (clone ,start))
327              (,sexpr-end (when (hemlock::form-offset ,sexpr-start 1) ,sexpr-start)))
328         #+sax-debug (when *limited-sexpr-end-debug*
329                       (debug-out "~%sexpr-end: ~S" ,sexpr-end))
330         (if ,sexpr-end
331           (when (mark<= ,sexpr-end ,limit) ,sexpr-end)
332           #+sax-debug (when *limited-sexpr-end-debug* 
333                         (debug-out "~%limited-sexpr-end returning nil - start-mark: ~S" ,start)))))))
334
335(defmacro next-sexpr-start (mark-or-form)
336  (let ((position (gensym))
337        (forward (gensym))
338        (start (gensym))
339        (param (gensym)))
340    ;; evaluate mark-or-form once, only:
341    `(let ((,param ,mark-or-form)) 
342       (when ,param
343         #+sax-debug (when *next-sexpr-start-debug*
344                      (debug-out "~%next-sexpr-start mark-or-form: ~S" ,mark-or-form)
345                      (debug-out "~%next-sexpr-start param: ~S" ,param))
346         (do* ((,position (clone ,param))
347               (,forward (when (hemlock::form-offset ,position 1) ,position)
348                         (when (hemlock::form-offset ,position 1) ,position))
349               (,start (when ,forward (when (hemlock::form-offset ,forward -1) ,forward))
350                       (when ,forward (when (hemlock::form-offset ,forward -1) ,forward))))
351              ((or (null ,start) (mark>= ,start ,param)) 
352               #+sax-debug (when (and *next-sexpr-start-debug* (null ,start)) 
353                            (debug-out "~%next-sexpr-start returning nil"))
354               (if *inc-p*
355                 (when (and ,start (mark< ,start *inc-pos*))
356                   ,start)
357                 ,start))
358           #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%start: ~S" ,start))
359           (hemlock::form-offset ,position 1)
360           #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%(form-offset position 1): ~S" ,position))
361           (cond ((null ,position) 
362                  #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%next-sexpr-start returning nil"))
363                  (return nil))
364                 ((mark<= ,position ,param)
365                  ;; wretched special case: avoid getting stuck:  ie.  (eq ,errsym #.^#$ o )
366                  #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%next-sexpr-start returning (mark-next ,position)"))
367                  (set-storage ,position ,param)
368                  (return (mark-next ,position)))))))))
369
370(defMacro nnext-sexpr-start (mark-or-form)
371  (let ((position (gensym))
372        (forward (gensym))
373        (start (gensym))
374        (param (gensym)))
375    `(let ((,param ,mark-or-form))
376       (when ,param
377         #+sax-debug (when *nnext-sexpr-start-debug*
378                      (debug-out "~%nnext-sexpr-start mark-or-form: ~S" ,mark-or-form)
379                      (debug-out "~%nnext-sexpr-start param: ~S" ,param))
380         (let* ((,position ,param)
381                (,forward (when (hemlock::form-offset ,position 1) ,position))
382                (,start (when ,forward (when (hemlock::form-offset ,forward -1) ,forward))))
383           #+sax-debug (when *nnext-sexpr-start-debug* 
384                        (if (null ,start)
385                          (debug-out "~%nnext-sexpr-start returning nil")
386                          (debug-out "~%nnext-sexpr-start returning: ~S" ,start)))
387           (if *inc-p*
388             (when (and ,start (mark< ,start *inc-pos*))
389               ,start)
390             ,start))))))
391
392(defMacro atom-start (start)
393  (let ((pos (gensym))
394        (char (gensym))
395        (buf-start (gensym)))
396    `(when ,start
397       (let ((,buf-start (buf-start-mark *buf*)))
398         (do* ((,pos ,start (mark-before ,pos))
399               (,char (when (and ,pos (mark>= ,pos ,buf-start))
400                        (mark-char ,pos))
401                      (when (and ,pos (mark>= ,pos ,buf-start))
402                        (mark-char ,pos))))
403              ((or (null ,char) ; ***
404                   (whitespacep ,char) (char= ,char #\() 
405                   (char= ,char #\)) (char= ,char #\"))
406               (if ,pos (mark-after ,pos) ,buf-start)))))))
407
408(defMacro atom-end (s)
409  (let ((start (gensym))
410        (buffer-end-mark (gensym))
411        (pos (gensym))
412        (char (gensym)))
413    `(when ,s
414       (let ((,start (clone ,s))
415             (,buffer-end-mark (buffer-end-mark *buf*)))
416         (do* ((,pos ,start (mark-after ,pos))
417               (,char (when (mark<= ,pos ,buffer-end-mark) (mark-char ,pos))
418                      (when (mark<= ,pos ,buffer-end-mark) (mark-char ,pos))))
419              ((or (null ,char) ; ***
420                   (whitespacep ,char) (char= ,char #\)) (char= ,char #\() 
421                   (char= ,char #\") (char= ,char #\;)) 
422               ,pos))))))
423
424(defun buffer-top-level-sexpr-start (buffer &optional storage)
425  (cond (storage
426         (set-storage storage (buffer-point buffer))
427         (hemlock::top-level-offset storage -1))
428        (t
429         (let ((mark (clone (buffer-point buffer))))
430           (hemlock::top-level-offset mark -1)))))
431
432(defun buffer-top-level-sexpr-end (buffer &optional storage)
433  (cond (storage
434         (set-storage storage (buffer-point buffer))
435         (hemlock::top-level-offset storage 1))
436        (t
437         (let ((mark (clone (buffer-point buffer))))
438           (hemlock::top-level-offset mark 1)))))
439
440
441;;; ----------------------------------------------------------------------------
442;;; Miscellaneous functions and macros.
443;;; ----------------------------------------------------------------------------
444;;;
445(defun pattern-search (mark pattern &optional end)
446  (with-mark ((m mark))
447    (if end 
448      (when (and (find-pattern m pattern) (mark< m end)) m)
449      (when (find-pattern m pattern) m))))
450
451#|
452;;; (buffer-writable buffer) is broken
453(defun writable-p (thing)
454  (declare (ignore thing))
455  t)
456
457(defun writable-path-p (path)
458  (let* ((file-manager (#/defaultManager ns:ns-file-manager))
459         (path (ccl::%make-nsstring path)))
460    (#/isWritableFileAtPath: file-manager path)))
461
462(defMethod writable-p ((hemlock-view hi::hemlock-view))
463  (let ((buffer (hemlock-view-buffer hemlock-view)))
464    (or (not *style-case-p*)
465        (format t "~%view-writable-p: ~S" (buffer-writable buffer))
466        ;; *** broken
467        (buffer-writable buffer))))
468
469(defMethod writable-p ((text-view gui::hemlock-textstorage-text-view))
470  (let* ((hemlock-view (gui::hemlock-view text-view))
471         (buffer (hemlock-view-buffer hemlock-view)))
472    (or (not *style-case-p*)
473        (format t "~%writable-p: ~S" (buffer-writable buffer))
474        (buffer-writable buffer))))
475
476(defMethod writable-p ((window gui::hemlock-frame))
477  (let* ((hemlock-view (gui::hemlock-view window))
478         (buffer (hemlock-view-buffer hemlock-view)))
479    (or (not *style-case-p*)
480        (format t "~%writable-p: ~S" (buffer-writable buffer))
481        (buffer-writable buffer))))
482|#
483
484(defun active-hemlock-window ()
485  "Return the active hemlock-frame."
486  (gui::first-window-satisfying-predicate 
487   #'(lambda (w)
488       (and (typep w 'gui::hemlock-frame)
489            (not (typep w 'gui::hemlock-listener-frame))
490            (#/isKeyWindow w)))))
491
492(defun window-path (w)
493  "Return the window's path."
494  (let* ((pane (slot-value w 'gui::pane))
495         (hemlock-view (when pane (gui::text-pane-hemlock-view pane)))
496         (buffer (when hemlock-view (hi::hemlock-view-buffer hemlock-view))))
497    (when buffer (hi::buffer-pathname buffer))))
498
499(defmacro char-eolp (char) 
500  `(member ,char '(#\return #\linefeed #\newline ,(code-char #x2028) ,(code-char #x2029))))
501
502(defun ed-beep () (#_NSBeep)) ; *** this beeper doesn't beep
503
504(define-symbol-macro *listener-output* (hemlock-ext::top-listener-output-stream))
505
506(defun listener-msg (string &rest args)
507  (apply 'format *listener-output* string args))
508
509(defun selection-marks (text-view)
510  (let ((selection (#/selectedRange text-view))
511        start end)
512    (when selection
513      (let ((length (ns:ns-range-length selection))
514            (location (ns:ns-range-location selection)))
515        (unless (zerop length)
516          (setf start (move-to-absolute-position (buf-start-mark) location))
517          (setf end (character-offset (clone start) length)))))
518    (values start end)))
519
520(defun key-event= (k1 k2)
521  (and (= (hi::key-event-keysym k1) (hi::key-event-keysym k2))
522       (= (hi::key-event-bits k1) (hi::key-event-bits k2))))
523
524(defmethod hemlock-update ((view hi:hemlock-view) start end &optional count)
525  (let* ((buffer (hemlock-view-buffer view))
526         (document (hi::buffer-document buffer))
527         (text-storage (if document (slot-value document 'gui::textstorage)))
528         (location (mark-absolute-position start))
529         (length (or count (- (mark-absolute-position end) location))))
530;         (count (hemlock::count-characters (region start end))))
531    #+sax-debug (when *hemlock-update-debug*
532                   (debug-out "~%~%~S" 'hemlock-update)
533                   (debug-out "~%start: ~S" start)
534                   (debug-out "~%end: ~S" end)
535                   (debug-out "~%location: ~S" location)
536                   (debug-out "~%length: ~S" length))
537    ;;; 0 is the fontnum
538    (gui::perform-edit-change-notification 
539     text-storage
540     (objc:@selector #/noteHemlockAttrChangeAtPosition:length:)
541     location length 0)))       
542
543(defmethod hemlock-update ((frame gui::hemlock-frame) start end &optional count)
544  (let ((hemlock-view (gui::hemlock-view frame)))
545    (hemlock-update hemlock-view start end count)))
546
547(defMacro attribute-dictionary (var) `(car ,var)) 
548
549(defMacro style-case (var) `(cdr ,var))
550
551(defun set-style-attributes (dictionary &optional (start (buf-start-mark))
552                                        (end (buf-end-mark)))
553  #+sax-debug (when *set-style-attributes-debug* 
554                 (debug-out "~%~%~S" 'set-style-attributes)
555                 (debug-out "~%dictionary: ~S" dictionary)
556                 (debug-out "~%start: ~S" start)
557                 (debug-out "~%end: ~S" end))
558
559  (ns:with-ns-range (range)
560    (let* ((location (mark-absolute-position start))
561           (length (- (mark-absolute-position end) location)))
562      (setf (ns:ns-range-location range) location)
563      (setf (ns:ns-range-length range) length)
564      ;; Remove all temporary attributes from the character range
565      (#/removeTemporaryAttribute:forCharacterRange:
566       *layout* #&NSForegroundColorAttributeName range)
567      (#/removeTemporaryAttribute:forCharacterRange:
568       *layout* #&NSUnderlineStyleAttributeName range)
569      (#/addTemporaryAttributes:forCharacterRange: *layout* dictionary range))))
570
571(defun set-generic-text-style (text-view &optional (start (buf-start-mark)) (end (buf-end-mark)))
572  ;; eliminate paren highlighting:
573  (let* ((begin (mark-absolute-position start))
574         (count (- (mark-absolute-position end) begin)))
575    (when (and begin count)
576      (ns:with-ns-range  (char-range begin count)
577        (let* ((layout (#/layoutManager text-view)))
578          (#/removeTemporaryAttribute:forCharacterRange: 
579           layout #&NSBackgroundColorAttributeName 
580           char-range)))))
581  ;; *** maybe chuck this:
582  (set-style-attributes  (attribute-dictionary *generic-text-style*) start end))
583
584(defun downcase-region (start end)
585  ;; downcases all nonescaped characters in region
586  (filter-region #'string-downcase (region start end)))
587
588(defun upcase-region (start end)
589  (filter-region #'string-upcase (region start end)))
590
591(defun capitalize-region (start end)
592  (filter-region #'string-capitalize (region start end)))
593
594(defMethod set-style-case ((case (eql :down)) start end)
595  (downcase-region start end))
596
597(defMethod set-style-case ((case (eql :up)) start end)
598  ;; don't use eupcase region...
599  (upcase-region start end))
600
601(defMethod set-style-case ((case (eql :unchanged)) start end)
602  (declare (ignore start end)) ())
603
604(defMethod set-style-case ((case (eql :cap)) start end)
605  (capitalize-region start end))
606
607(defMethod set-style-case ((case (eql :cap3)) start end)
608  (set-style-case :down start end)
609  (capitalize-region (mark-offset start 3) (mark-offset start 4)))
610
611(defMethod set-style-case ((case (eql :cap03)) start end)
612  (set-style-case :down start end)
613  (capitalize-region start end)
614  (capitalize-region (mark-offset start 3) (mark-offset start 4)))
615
616(defMethod set-style-case ((case (eql :cap8)) start end)
617  (set-style-case :down start end)
618  (capitalize-region (mark-offset start 8) (mark-offset start 9)))
619
620(defMethod set-style-case ((case (eql :cap12)) start end)
621  (set-style-case :down start end)
622  (capitalize-region (mark-offset start 12) (mark-offset start 13)))
623
624(defMacro style-region (style start end  &optional (set-case-p t))
625  "This is the basic styling macro that calls SET-STYLE-ATTRIBUTES and SET-STYLE-CASE."
626  `(progn
627     #+sax-debug (when *style-region-debug* 
628                  (debug-out "~%~%~S" 'style-region)
629                  (debug-out "~%start: ~S" ,start)
630                  (debug-out "~%end: ~S" ,end)
631                  (debug-out "~%style: ~S" ,style)
632                  (debug-out "~%set-case-p: ~S" ,set-case-p)
633                  (debug-out "~%*paste-p*: ~S" *paste-p*)
634                  (debug-out "~%*paste-start*: ~S" *paste-start*)
635                  (debug-out "~%*paste-end*: ~S" *paste-end*)
636                  (debug-out "~%*inc-p*: ~S" *inc-p*)
637                  (debug-out "~%*inc-pos*: ~S" *inc-pos*))
638     (when (or (and *inc-p* (not *paste-p*)
639                    (mark>= *inc-pos* ,start)
640                    (mark<= *inc-pos* ,end))
641               (not *inc-p*)
642               (and *paste-p*
643                    (mark>= ,start *paste-start*)
644                    (mark<= ,end *paste-end*)))
645
646       (when (and *style-case-p* ,set-case-p (style-case ,style))
647         #+sax-debug (when *style-region-debug*
648                      (debug-out "~%set-style-case, case: ~S" (style-case ,style))
649                      (debug-out "~%set-style-case, region: ~S" (region ,start ,end)))
650           (set-style-case (style-case ,style) ,start ,end))
651
652       (cond ((and *inc-p* (not *paste-p*))
653              ;; Don't set attributes when doing incremental. We are
654              ;; inside #/beginEditing, #/endEditing.  Save the values.
655              #+sax-debug (when *style-region-debug* 
656                            (debug-out "~%~%*** setting *form-style* for: ~S ***" 
657                                       (region-to-string (region ,start ,end))))
658              (setq *form-style* ,style
659                    *form-start* ,start
660                    *form-end* ,end))
661             (t
662              #+sax-debug (when *style-region-debug*
663                             (if (equalp ,style *generic-text-style*)
664                               (debug-out "~%*** styling-region-generically: ~S ***"
665                                          (region-to-string (region ,start ,end)))
666                               (debug-out "~%*** styling-region: ~S ***"
667                                          (region-to-string (region ,start ,end))))
668                             (debug-out "~%style: ~S" ,style))
669              (set-style-attributes (attribute-dictionary ,style) ,start ,end))))))
670
671
Note: See TracBrowser for help on using the repository browser.