source: trunk/source/cocoa-ide/hemlock-text.lisp @ 12572

Last change on this file since 12572 was 12572, checked in by rme, 11 years ago

In charpropos-to-dict: #/convertFont:toHaveTrait: can only do one
trait at a time, so don't try save up a mask of traits to apply all at
once. Process :font-color and :background-color charprops.

ns-color-from-charprop: New function. Only knows about the "#aabbcc"
format for specifying colors.

File size: 20.5 KB
Line 
1(in-package "GUI")
2
3;;; NSMutableString subclass that uses a Hemlock buffer for
4;;; character storage.
5
6(defclass xhemlock-buffer-string (ns:ns-mutable-string)
7  ((cache :initform (reset-buffer-cache
8                     (make-buffer-cache :buffer (make-untitled-buffer)))
9          :initarg :cache :accessor hemlock-buffer-string-cache))
10  (:metaclass ns:+ns-object))
11
12(defmethod hemlock-buffer ((self xhemlock-buffer-string))
13  (with-slots (cache) self
14    (when cache
15      (buffer-cache-buffer cache))))
16
17(defvar *untitled-buffer-counter* 0)
18
19(defun next-untitled-buffer-counter ()
20  (ccl::atomic-incf *untitled-buffer-counter*))
21
22(defun make-untitled-buffer ()
23  (loop
24    (let* ((name (format nil "untitled-~d" (next-untitled-buffer-counter)))
25           (buffer (hi:make-buffer name)))
26      (when buffer
27        (return buffer)))))
28
29(objc:defmethod (#/dealloc :void) ((self xhemlock-buffer-string))
30  (let ((buffer (hemlock-buffer self)))
31    (when buffer
32      (when (eq buffer hi::*current-buffer*)
33        (setf hi::*current-buffer* nil))
34      (setf (hi::buffer-document buffer) nil)
35      ;; It makes sense to me to delete the buffer here, but
36      ;; the existing code does it in response to closing a document.
37      ;;(hi::delete-buffer buffer)
38      (setf (slot-value self 'cache) nil)
39      (call-next-method))))
40
41;;; NSMutableString primitive method
42
43(objc:defmethod (#/replaceCharactersInRange:withString: :void)
44                ((self xhemlock-buffer-string) (range #>NSRange) string)
45  (let* ((buffer (hemlock-buffer self))
46         (cache (hemlock-buffer-string-cache self))
47         (hi::*current-buffer* buffer)
48         (position (pref range #>NSRange.location))
49         (length (pref range #>NSRange.length))
50         (lisp-string (if (> (#/length string) 0) (lisp-string-from-nsstring string))))
51    (hi:with-mark ((m (hi:buffer-point buffer)))
52      (move-hemlock-mark-to-absolute-position m cache position)
53      (when (> length 0)
54        (hi:delete-characters m length))
55      (when lisp-string
56        (hi:insert-string m lisp-string)))))
57
58;;; NSString primitive methods
59
60(objc:defmethod (#/length #>NSUInteger) ((self xhemlock-buffer-string))
61  (let* ((cache (hemlock-buffer-string-cache self)))
62    (or (buffer-cache-buflen cache)
63        (setf (buffer-cache-buflen cache)
64              (let* ((buffer (buffer-cache-buffer cache)))
65                (hemlock-buffer-length buffer))))))
66
67#+slow
68(objc:defmethod (#/length #>NSUInteger) ((self xhemlock-buffer-string))
69  (let* ((buffer (hemlock-buffer self))
70         (hi::*current-buffer* buffer))
71    (hi:count-characters (hi:buffer-region buffer))))
72
73(objc:defmethod (#/characterAtIndex: :unichar) ((self xhemlock-buffer-string)
74                                                (index #>NSUInteger))
75  (char-code (hemlock-char-at-index (hemlock-buffer-string-cache self) index)))
76
77#+slow
78(objc:defmethod (#/characterAtIndex: :unichar) ((self xhemlock-buffer-string) (index #>NSUInteger))
79  (let* ((buffer (hemlock-buffer self))
80         (hi::*current-buffer* buffer)
81         (start (hi:buffer-start-mark buffer)))
82    (hi:with-mark ((m start))
83      (if (hi:character-offset m index)
84        ;; If the lisp character can't be represented as a 16-bit UTF-16
85        ;; code point (i.e., the character needs to be encoded with a surrogate
86        ;; pair), just punt and return the replacement character.  This is
87        ;; clearly not good for Gilgamesh (presumably a cuneiform user), among
88        ;; others. If we keep using the Cocoa text system, we'll have to hair
89        ;; things up to deal with this at some point.
90        (let* ((char (or (hi:next-character m)
91                         (error "index ~d out of range" index)))
92               (code (char-code char)))
93          (if (< code #x10000)
94            code
95            #\Replacement_Character))))))
96
97(objc:defmethod (#/getCharacters:range: :void) ((self xhemlock-buffer-string)
98                                                (buffer (:* :unichar))
99                                                (r :<NSR>ange))
100  (let* ((cache (hemlock-buffer-string-cache self))
101         (index (ns:ns-range-location r))
102         (length (ns:ns-range-length r))
103         (hi::*current-buffer* (buffer-cache-buffer cache)))
104    #+debug
105    (#_NSLog #@"get characters: %d/%d"
106             :<NSUI>nteger index
107             :<NSUI>nteger length)
108    (multiple-value-bind (line idx) (update-line-cache-for-index cache index)
109      (let* ((len (hemlock::line-length line)))
110        (do* ((i 0 (1+ i)))
111             ((= i length))
112          (cond ((< idx len)
113                 (setf (paref buffer (:* :unichar) i)
114                       (char-code (hemlock::line-character line idx)))
115                 (incf idx))
116                (t
117                 (setf (paref buffer (:* :unichar) i)
118                       (char-code #\Newline)
119                       line (hi::line-next line)
120                       len (if line (hi::line-length line) 0)
121                       idx 0))))))))
122
123
124;;; This is bound to T when we edit text using the methods of
125;;; NSTextStorage.  These keeps the Hemlock text primitives from
126;;; calling edited:range:changeInLength: on their own.
127(defvar *suppress-edit-notifications* nil)
128
129;;; NSTextStorage subclass that uses a HemlockBufferString for
130;;; text storage, and for character attributes, too.
131
132(defclass xhemlock-text-storage (ns:ns-text-storage)
133  ((hemlock-string :foreign-type :id :reader hemlock-string)
134   (edit-count :foreign-type :int)
135   (selection-set-by-search :foreign-type #>BOOL))
136  (:metaclass ns:+ns-object))
137
138(defmethod (setf hemlock-string) (new (self xhemlock-text-storage))
139  (with-slots (hemlock-string) self
140    (unless (eql hemlock-string new)
141      (#/release hemlock-string)
142      (setf hemlock-string (#/retain new)))))
143
144(objc:defmethod (#/dealloc :void) ((self xhemlock-text-storage))
145  (setf (hemlock-string self) +null-ptr+)
146  (call-next-method))
147
148(objc:defmethod #/hemlockString ((self xhemlock-text-storage))
149  (slot-value self 'hemlock-string))
150
151(objc:defmethod (#/updateMirror :void) ((self xhemlock-text-storage))
152  ;; don't need to do anything
153  )
154
155(defmethod hemlock-buffer ((self xhemlock-text-storage))
156  (let ((string (hemlock-string self)))
157    (unless (%null-ptr-p string)
158      (hemlock-buffer string))))
159
160(objc:defmethod #/initWithString: ((self xhemlock-text-storage) string)
161  (setq string (%inc-ptr string 0)) ;avoid stack-consed macptr?
162  (ccl::%call-next-objc-method self (find-class 'xhemlock-text-storage)
163                               (@selector #/init) '(:id))
164  (setf (slot-value self 'hemlock-string) (#/retain string))
165  self)
166
167(objc:defmethod #/init ((self xhemlock-text-storage))
168  (#/initWithString: self (make-instance 'xhemlock-buffer-string)))
169
170(objc:defmethod #/string ((self xhemlock-text-storage))
171  (hemlock-string self))
172
173(objc:defmethod (#/replaceCharactersInRange:withString: :void)
174                ((self xhemlock-text-storage) (range #>NSRange) string)
175  (let* ((orig-len (#/length self))
176         (contents (hemlock-string self))
177         (*suppress-edit-notifications* t))
178    (#/replaceCharactersInRange:withString: contents range string)
179    (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters
180                                    range (- (#/length self) orig-len))))
181
182(objc:defmethod (#/setAttributes:range: :void) ((self xhemlock-text-storage)
183                                                (attributes :id)
184                                                (range #>NSRange))
185  (let* ((string (hemlock-string self))
186         (cache (hemlock-buffer-string-cache self))
187         (buffer (hemlock-buffer string))
188         (hi::*current-buffer* buffer)
189         (*suppress-edit-notifications* t))
190    (hi:with-mark ((start (hi:buffer-point buffer))
191                   (end (hi:buffer-point buffer)))
192      (move-hemlock-mark-to-absolute-position start cache
193                                              (ns:ns-range-location range))
194      (move-hemlock-mark-to-absolute-position end cache
195                                              (+ (ns:ns-range-location range)
196                                                 (ns:ns-range-length range)))
197      (hi::set-region-charprops (hi:region start end) (dict-to-charprops attributes))))
198  (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes
199                                  range 0))
200
201;;; This appears to be called at every blink of the insertion point.
202(objc:defmethod #/attributesAtIndex:effectiveRange: ((self xhemlock-text-storage)
203                                                     (location #>NSUInteger)
204                                                     (rangeptr (* #>NSRange)))
205  (let* ((buffer (hemlock-buffer (hemlock-string self)))
206         (hi::*current-buffer* buffer))
207    (hi:with-mark ((m (hi:buffer-point buffer)))
208      (move-hemlock-mark-to-absolute-position m
209                                              (hemlock-buffer-string-cache
210                                               (hemlock-string self))
211                                              location)
212      (multiple-value-bind (plist start end)
213                           (hi::line-charprops-for-position (hi:mark-line m) (hi:mark-charpos m))
214        (unless (%null-ptr-p rangeptr)
215          (let ((origin (hi::get-line-origin (hi:mark-line m))))
216            (incf start origin)
217            (incf end origin)
218            (setf (pref rangeptr #>NSRange.location) start
219                  (pref rangeptr #>NSRange.length) (- end start))))
220        ;; This conses up a brand-new NSDictionary every time.
221        ;; Some sort of caching may be profitable here (or not...)
222        (charprops-to-dict plist)))))
223
224;;; Return true iff we're inside a "beginEditing/endEditing" pair
225(objc:defmethod (#/editingInProgress :<BOOL>) ((self xhemlock-text-storage))
226  ;; This is meaningless outside the event thread, since you can't tell what
227  ;; other edit-count changes have already been queued up for execution on
228  ;; the event thread before it gets to whatever you might queue up next.
229  (assume-cocoa-thread)
230  (> (slot-value self 'edit-count) 0))
231
232(objc:defmethod (#/noteHemlockInsertionAtPosition:length: :void)
233    ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger)
234     (extra :<NSI>nteger))
235  (declare (ignore extra))
236  (let* ((buffer (hemlock-buffer self))
237         (document (hi::buffer-document buffer))
238         (undo-mgr (and document (#/undoManager document))))
239    (when (and undo-mgr (not (#/isUndoing undo-mgr)))
240      (#/replaceCharactersInRange:withString:
241       (#/prepareWithInvocationTarget: undo-mgr self)
242       (ns:make-ns-range pos n) #@"")))
243  (let ((cache (hemlock-buffer-string-cache (hemlock-string self))))
244    (adjust-buffer-cache-for-insertion cache pos n)
245    (update-line-cache-for-index cache pos))
246  (unless *suppress-edit-notifications*
247    (textstorage-note-insertion-at-position self pos n)))
248
249(objc:defmethod (#/noteHemlockDeletionAtPosition:length: :void)
250    ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger)
251     (extra :<NSI>nteger))
252  (declare (ignorable extra))
253  (let ((cache (hemlock-buffer-string-cache (hemlock-string self))))
254    (reset-buffer-cache cache)
255    (update-line-cache-for-index cache pos))
256  (unless *suppress-edit-notifications*
257    (ns:with-ns-range (range pos n)
258      (#/edited:range:changeInLength: self
259                                      (logior #$NSTextStorageEditedCharacters
260                                              #$NSTextStorageEditedAttributes)
261                                      range (- n)))))
262
263(objc:defmethod (#/noteHemlockModificationAtPosition:length: :void)
264    ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger)
265     (extra :<NSI>nteger))
266  (declare (ignorable extra))
267  (unless *suppress-edit-notifications*
268    (ns:with-ns-range (range pos n)
269      (#/edited:range:changeInLength: self 
270                                      (logior #$NSTextStorageEditedCharacters
271                                              #$NSTextStorageEditedAttributes)
272                                      range 0))))
273
274(objc:defmethod (#/noteHemlockAttrChangeAtPosition:length: :void)
275    ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger)
276     (fontnum :<NSI>nteger))
277  (declare (ignore fontnum))
278  (unless *suppress-edit-notifications*
279    (ns:with-ns-range (range pos n)
280      (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes
281                                      range 0))))
282
283(defmethod assume-not-editing ((ts xhemlock-text-storage))
284  #+debug NIL (assert (eql (slot-value ts 'edit-count) 0)))
285
286(defmethod update-hemlock-selection ((self xhemlock-text-storage))
287  (assume-cocoa-thread)
288  (let ((buffer (hemlock-buffer self)))
289    (multiple-value-bind (start end) (hi:buffer-selection-range buffer)
290      #+debug
291      (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"
292               :int (hi::mark-charpos (hi::buffer-point buffer)) :int start)
293      (for-each-textview-using-storage
294       self
295       #'(lambda (tv)
296           (#/updateSelection:length:affinity: tv
297                                               start
298                                               (- end start)
299                                               (if (eql start 0)
300                                                 #$NSSelectionAffinityUpstream
301                                                 #$NSSelectionAffinityDownstream)))))))
302
303
304;;; Tabs are going to be a problem.
305(defloadvar *default-paragraph-style*
306    (let* ((style (#/mutableCopy (#/defaultParagraphStyle ns:ns-paragraph-style)))
307           (charwidth (nth-value 1 (size-of-char-in-font *editor-font*))))
308      (#/setLineBreakMode: style #$NSLineBreakByCharWrapping)
309      (#/setTabStops: style (#/array ns:ns-array))
310      (#/setDefaultTabInterval: style (* *tab-width* charwidth))
311      style))
312
313(defun ns-color-to-charprop (color)
314  (let ((color (#/colorUsingColorSpaceName: color #&NSCalibratedRGBColorSpace)))
315    (rlet ((r #>CGFloat)
316           (g #>CGFloat)
317           (b #>CGFloat)
318           (a #>CGFloat))
319      (#/getRed:green:blue:alpha: color r g b a)
320      (flet ((scale (f)
321               (floor (* 255 f))))
322        (let* ((rr (scale (pref r #>CGFloat)))
323               (gg (scale (pref g #>CGFloat)))
324               (bb (scale (pref b #>CGFloat))))
325          (format nil "#~2,'0x~2,'0x~2,'0x" rr gg bb))))))
326
327(defvar *charprop-colors* (make-hash-table :test #'equalp))
328
329(defun ns-color-from-charprop (color-string)
330  (or (gethash color-string *charprop-colors*)
331      (when (and (= (length color-string) 7)
332                 (char= (char color-string 0) #\#))
333        (let* ((rr (ignore-errors (parse-integer color-string :start 1 :end 3 :radix 16)))
334               (gg (ignore-errors (parse-integer color-string :start 3 :end 5 :radix 16)))
335               (bb (ignore-errors (parse-integer color-string :start 5 :end 7 :radix 16)))
336               (aa (cgfloat 1)))
337          (when (and rr gg bb)
338            (setq rr (cgfloat (/ rr 255.0))
339                  gg (cgfloat (/ gg 255.0))
340                  bb (cgfloat (/ bb 255.0)))
341            (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color
342                                                        rr gg bb aa))))))
343(defun dict-to-charprops (dict)
344  (let ((enumerator (#/keyEnumerator dict))
345        (plist nil))
346    (loop
347      (let ((key (#/nextObject enumerator)))
348        (when (%null-ptr-p key)
349          (return plist))
350        (let ((value (#/objectForKey: dict key))
351              (keyword (car (rassoc key hi::*cocoa-attributes* :test #'ns-string-equal))))
352          (case keyword
353            (:ns-font
354             (let* ((font value)
355                    (descriptor (#/fontDescriptor font))
356                    (traits-mask (#/symbolicTraits descriptor))
357                    (name (lisp-string-from-nsstring (#/familyName font)))
358                    (size (cgfloat (#/pointSize font))))
359               (setq plist (nconc plist (list :font-name name :font-size size)))
360               (when (logtest traits-mask #$NSFontItalicTrait)
361                 (setq plist (nconc plist (list :font-slant :italic))))
362               (when (logtest traits-mask #$NSFontBoldTrait)
363                 (setq plist (nconc plist (list :font-weight :bold))))
364               (if (logtest traits-mask #$NSFontExpandedTrait)
365                 (setq plist (nconc plist (list :font-width :exapnded)))
366                 (if (logtest traits-mask #$NSFontCondensedTrait)
367                   (setq plist (nconc plist (list :font-width :condensed)))))))
368            (:ns-paragraph-style )
369            (:ns-foreground-color
370             (let* ((color value)
371                    (color-string (ns-color-to-charprop color)))
372               (setq plist (nconc plist (list :font-color color-string)))))
373            (:ns-underline-style
374             (let* ((style (#/intValue value))
375                    (underline-keyword (cond ((= style #$NSUnderlineStyleSingle)
376                                              :single)
377                                             ((= style #$NSUnderlineStyleDouble)
378                                              :double)
379                                             ((= style #$NSUnderlineStyleThick)
380                                              :thick))))
381               (when underline-keyword
382                 (setq plist (nconc plist (list :font-underline underline-keyword))))))
383            (:ns-superscript )
384            (:ns-background-color 
385             (let* ((color value)
386                    (color-string (ns-color-to-charprop color)))
387               (setq plist (nconc plist (list :background-color color-string)))))
388            (:ns-attachment (format t "~s" keyword))
389            (:ns-ligature (format t "~s" keyword))
390            (:ns-baseline-offset (format t "~s" keyword))
391            (:ns-kern (format t "~s" keyword))
392            (:ns-link (format t "~s" keyword))
393            (:ns-stroke-width (format t "~s" keyword))
394            (:ns-stroke-color (format t "~s" keyword))
395            (:ns-underline-color (format t "~s" keyword))
396            (:ns-strikethrough-style (format t "~s" keyword))
397            (:ns-strikethrough-color (format t "~s" keyword))
398            (:ns-shadow (format t "~s" keyword))
399            (:ns-obliqueness (format t "~s" keyword))
400            (:ns-expansion (format t "~s" keyword))
401            (:ns-cursor (format t "~s" keyword))
402            (:ns-tool-tip (format t "~s" keyword))
403            (:ns-character-shap (format t "~s" keyword))
404            (:ns-glyph-info (format t "~s" keyword))))))))
405
406(defun charprops-to-dict (plist)
407  (when (null plist)
408    (return-from charprops-to-dict
409                 (#/dictionaryWithObjectsAndKeys: ns:ns-dictionary
410                                                  *default-paragraph-style*
411                                                  #&NSParagraphStyleAttributeName
412                                                  *editor-font*
413                                                  #&NSFontAttributeName
414                                                  +null-ptr+)))
415  (let* ((dict (#/dictionaryWithCapacity: ns:ns-mutable-dictionary 8))
416         (default-font *editor-font*)   ;what about listeners?
417         (fm (#/sharedFontManager ns:ns-font-manager))
418         (font +null-ptr+)
419         (font-name nil))
420    (#/setObject:forKey: dict *default-paragraph-style*
421                         #&NSParagraphStyleAttributeName)
422    (setq font-name (getf plist :font-name))
423    (when font-name
424      (case font-name
425        (:document-font (setq font (#/userFontOfSize: ns:ns-font 0.0)))
426        (:fixed-font (setq font (#/userFixedPitchFontOfSize: ns:ns-font 0.0)))
427        (:system-font (setq font (#/systemFontOfSize: ns:ns-font 0.0)))
428        (t (setq font (#/fontWithName:size: ns:ns-font
429                                            (#/autorelease (%make-nsstring font-name))
430                                            0.0)))))
431    (when (%null-ptr-p font)
432      (setq font default-font))
433    (loop for (k v) on plist by #'cddr
434      do (case k
435           (:font-size
436            (setq v (float v ns:+cgfloat-zero+))
437            (setq font (#/convertFont:toSize: fm font v)))
438           (:font-weight
439            (cond
440              ((eq v :bold)
441               (setq font (#/convertFont:toHaveTrait: fm font #$NSBoldFontMask)))
442              ((eq v :plain)
443               (setq font (#/convertFont:toHaveTrait: fm font #$NSUnboldFontMask)))))
444           (:font-width
445            (cond
446              ((eq v :condensed)
447               (setq font (#/convertFont:toHaveTrait: fm font #$NSCondensedFontMask)))
448              ((eq v :expanded)
449               (setq font (#/convertFont:toHaveTrait: fm font #$NSExpandedFontMask)))))
450           (:font-slant
451            (cond ((eq v :italic)
452                   (setq font (#/convertFont:toHaveTrait: fm font #$NSItalicFontMask)))
453                  ((eq v :roman)
454                   (setq font (#/convertFont:toHaveTrait: fm font #$NSUnitalicFontMask)))))
455           (:font-underline
456            (let (n)
457              (case v
458                (:single
459                 (setq n (#/numberWithInt: ns:ns-number #$NSUnderlineStyleSingle)))
460                (:double
461                 (setq n (#/numberWithInt: ns:ns-number #$NSUnderlineStyleDouble)))
462                (:thick
463                 (setq n (#/numberWithInt: ns:ns-number #$NSUnderlineStyleThick))))
464              (when n
465                (#/setObject:forKey: dict n #&NSUnderlineStyleAttributeName))))
466           (:font-color
467            (let ((color (ns-color-from-charprop v)))
468              (when color
469                (#/setObject:forKey: dict color #&NSForegroundColorAttributeName))))
470           (:background-color
471            (let ((color (ns-color-from-charprop v)))
472              (when color
473                (#/setObject:forKey: dict color #&NSBackgroundColorAttributeName))))))
474    (unless (%null-ptr-p font)
475      (#/setObject:forKey: dict font #&NSFontAttributeName))
476    dict))
477
478(defclass xhemlock-text-view (ns:ns-text-view)
479  ()
480  (:metaclass ns:+ns-object))
481
482;;; replaces version in cocoa-editor.lisp
483
484(defun make-textstorage-for-hemlock-buffer (buffer)
485  (make-instance 'xhemlock-text-storage
486                 :with-string
487                 (make-instance
488                  'xhemlock-buffer-string
489                  :cache
490                  (reset-buffer-cache
491                   (make-buffer-cache)
492                   buffer))))
Note: See TracBrowser for help on using the repository browser.