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

Last change on this file since 14489 was 14489, checked in by rme, 9 years ago

method signature changes as made in r14363.

File size: 21.3 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 (hemlock-string 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 (#/beginEditing :void) ((self xhemlock-text-storage))
233  (assume-cocoa-thread)
234  (with-slots (edit-count) self
235    #+debug
236    (#_NSLog #@"begin-editing")
237    (incf edit-count)
238    #+debug
239    (#_NSLog #@"after beginEditing on %@ edit-count now = %d" :id self :int edit-count)
240    (call-next-method)))
241
242(objc:defmethod (#/endEditing :void) ((self xhemlock-text-storage))
243  (assume-cocoa-thread)
244  (with-slots (edit-count) self
245    #+debug
246    (#_NSLog #@"end-editing")
247    (call-next-method)
248    (assert (> edit-count 0))
249    (decf edit-count)
250    #+debug
251    (#_NSLog #@"after endEditing on %@, edit-count now = %d" :id self :int edit-count)))
252
253(objc:defmethod (#/noteHemlockInsertionAtPosition:length:extra: :void)
254    ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger)
255     (extra :<NSI>nteger))
256  (declare (ignore extra))
257  (let* ((buffer (hemlock-buffer self))
258         (document (hi::buffer-document buffer))
259         (undo-mgr (and document (#/undoManager document))))
260    (when (and undo-mgr (not (#/isUndoing undo-mgr)))
261      (#/replaceCharactersInRange:withString:
262       (#/prepareWithInvocationTarget: undo-mgr self)
263       (ns:make-ns-range pos n) #@"")))
264  (let ((cache (hemlock-buffer-string-cache (hemlock-string self))))
265    (adjust-buffer-cache-for-insertion cache pos n)
266    (update-line-cache-for-index cache pos))
267  (unless *suppress-edit-notifications*
268    (textstorage-note-insertion-at-position self pos n)))
269
270(objc:defmethod (#/noteHemlockDeletionAtPosition:length:extra: :void)
271    ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger)
272     (extra :<NSI>nteger))
273  (declare (ignorable extra))
274  (let ((cache (hemlock-buffer-string-cache (hemlock-string self))))
275    (reset-buffer-cache cache)
276    (update-line-cache-for-index cache pos))
277  (unless *suppress-edit-notifications*
278    (ns:with-ns-range (range pos n)
279      (#/edited:range:changeInLength: self
280                                      (logior #$NSTextStorageEditedCharacters
281                                              #$NSTextStorageEditedAttributes)
282                                      range (- n)))))
283
284(objc:defmethod (#/noteHemlockModificationAtPosition:length:extra: :void)
285    ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger)
286     (extra :<NSI>nteger))
287  (declare (ignorable extra))
288  (unless *suppress-edit-notifications*
289    (ns:with-ns-range (range pos n)
290      (#/edited:range:changeInLength: self 
291                                      (logior #$NSTextStorageEditedCharacters
292                                              #$NSTextStorageEditedAttributes)
293                                      range 0))))
294
295(objc:defmethod (#/noteHemlockAttrChangeAtPosition:length:fontNum: :void)
296    ((self xhemlock-text-storage) (pos :<NSI>nteger) (n :<NSI>nteger)
297     (fontnum :<NSI>nteger))
298  (declare (ignore fontnum))
299  (unless *suppress-edit-notifications*
300    (ns:with-ns-range (range pos n)
301      (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes
302                                      range 0))))
303
304(defmethod assume-not-editing ((ts xhemlock-text-storage))
305  #+debug NIL (assert (eql (slot-value ts 'edit-count) 0)))
306
307(defmethod update-hemlock-selection ((self xhemlock-text-storage))
308  (assume-cocoa-thread)
309  (let ((buffer (hemlock-buffer self)))
310    (multiple-value-bind (start end) (hi:buffer-selection-range buffer)
311      #+debug
312      (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"
313               :int (hi::mark-charpos (hi::buffer-point buffer)) :int start)
314      (for-each-textview-using-storage
315       self
316       #'(lambda (tv)
317           (#/updateSelection:length:affinity: tv
318                                               start
319                                               (- end start)
320                                               (if (eql start 0)
321                                                 #$NSSelectionAffinityUpstream
322                                                 #$NSSelectionAffinityDownstream)))))))
323
324
325;;; Tabs are going to be a problem.
326(defloadvar *default-paragraph-style*
327    (let* ((style (#/mutableCopy (#/defaultParagraphStyle ns:ns-paragraph-style)))
328           (charwidth (nth-value 1 (size-of-char-in-font *editor-font*))))
329      (#/setLineBreakMode: style #$NSLineBreakByCharWrapping)
330      (#/setTabStops: style (#/array ns:ns-array))
331      (#/setDefaultTabInterval: style (* *tab-width* charwidth))
332      style))
333
334(defun ns-color-to-charprop (color)
335  (let ((color (#/colorUsingColorSpaceName: color #&NSCalibratedRGBColorSpace)))
336    (rlet ((r #>CGFloat)
337           (g #>CGFloat)
338           (b #>CGFloat)
339           (a #>CGFloat))
340      (#/getRed:green:blue:alpha: color r g b a)
341      (flet ((scale (f)
342               (floor (* 255 f))))
343        (let* ((rr (scale (pref r #>CGFloat)))
344               (gg (scale (pref g #>CGFloat)))
345               (bb (scale (pref b #>CGFloat))))
346          (format nil "#~2,'0x~2,'0x~2,'0x" rr gg bb))))))
347
348(defvar *charprop-colors* (make-hash-table :test #'equalp))
349
350(defun ns-color-from-charprop (color-string)
351  (or (gethash color-string *charprop-colors*)
352      (when (and (= (length color-string) 7)
353                 (char= (char color-string 0) #\#))
354        (let* ((rr (ignore-errors (parse-integer color-string :start 1 :end 3 :radix 16)))
355               (gg (ignore-errors (parse-integer color-string :start 3 :end 5 :radix 16)))
356               (bb (ignore-errors (parse-integer color-string :start 5 :end 7 :radix 16)))
357               (aa (cgfloat 1)))
358          (when (and rr gg bb)
359            (setq rr (cgfloat (/ rr 255.0))
360                  gg (cgfloat (/ gg 255.0))
361                  bb (cgfloat (/ bb 255.0)))
362            (setf (gethash color-string *charprop-colors*)
363                  (#/retain (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color
364                                                                        rr gg bb aa))))))))
365(defun dict-to-charprops (dict)
366  (let ((enumerator (#/keyEnumerator dict))
367        (plist nil))
368    (loop
369      (let ((key (#/nextObject enumerator)))
370        (when (%null-ptr-p key)
371          (return plist))
372        (let ((value (#/objectForKey: dict key))
373              (keyword (car (rassoc key hi::*cocoa-attributes* :test #'ns-string-equal))))
374          (case keyword
375            (:ns-font
376             (let* ((font value)
377                    (descriptor (#/fontDescriptor font))
378                    (traits-mask (#/symbolicTraits descriptor))
379                    (name (lisp-string-from-nsstring (#/familyName font)))
380                    (size (cgfloat (#/pointSize font))))
381               (setq plist (nconc plist (list :font-name name :font-size size)))
382               (when (logtest traits-mask #$NSFontItalicTrait)
383                 (setq plist (nconc plist (list :font-slant :italic))))
384               (when (logtest traits-mask #$NSFontBoldTrait)
385                 (setq plist (nconc plist (list :font-weight :bold))))
386               (if (logtest traits-mask #$NSFontExpandedTrait)
387                 (setq plist (nconc plist (list :font-width :exapnded)))
388                 (if (logtest traits-mask #$NSFontCondensedTrait)
389                   (setq plist (nconc plist (list :font-width :condensed)))))))
390            (:ns-paragraph-style )
391            (:ns-foreground-color
392             (let* ((color value)
393                    (color-string (ns-color-to-charprop color)))
394               (setq plist (nconc plist (list :font-color color-string)))))
395            (:ns-underline-style
396             (let* ((style (#/intValue value))
397                    (underline-keyword (cond ((= style #$NSUnderlineStyleSingle)
398                                              :single)
399                                             ((= style #$NSUnderlineStyleDouble)
400                                              :double)
401                                             ((= style #$NSUnderlineStyleThick)
402                                              :thick))))
403               (when underline-keyword
404                 (setq plist (nconc plist (list :font-underline underline-keyword))))))
405            (:ns-superscript )
406            (:ns-background-color 
407             (let* ((color value)
408                    (color-string (ns-color-to-charprop color)))
409               (setq plist (nconc plist (list :background-color color-string)))))
410            (:ns-attachment (format t "~s" keyword))
411            (:ns-ligature (format t "~s" keyword))
412            (:ns-baseline-offset (format t "~s" keyword))
413            (:ns-kern (format t "~s" keyword))
414            (:ns-link (format t "~s" keyword))
415            (:ns-stroke-width (format t "~s" keyword))
416            (:ns-stroke-color (format t "~s" keyword))
417            (:ns-underline-color (format t "~s" keyword))
418            (:ns-strikethrough-style (format t "~s" keyword))
419            (:ns-strikethrough-color (format t "~s" keyword))
420            (:ns-shadow (format t "~s" keyword))
421            (:ns-obliqueness (format t "~s" keyword))
422            (:ns-expansion (format t "~s" keyword))
423            (:ns-cursor (format t "~s" keyword))
424            (:ns-tool-tip (format t "~s" keyword))
425            (:ns-character-shap (format t "~s" keyword))
426            (:ns-glyph-info (format t "~s" keyword))))))))
427
428(defun charprops-to-dict (plist)
429  (when (null plist)
430    (return-from charprops-to-dict
431                 (#/dictionaryWithObjectsAndKeys: ns:ns-dictionary
432                                                  *default-paragraph-style*
433                                                  #&NSParagraphStyleAttributeName
434                                                  *editor-font*
435                                                  #&NSFontAttributeName
436                                                  +null-ptr+)))
437  (let* ((dict (#/dictionaryWithCapacity: ns:ns-mutable-dictionary 8))
438         (default-font *editor-font*)   ;what about listeners?
439         (fm (#/sharedFontManager ns:ns-font-manager))
440         (font +null-ptr+)
441         (font-name nil))
442    (#/setObject:forKey: dict *default-paragraph-style*
443                         #&NSParagraphStyleAttributeName)
444    (setq font-name (getf plist :font-name))
445    (when font-name
446      (case font-name
447        (:document-font (setq font (#/userFontOfSize: ns:ns-font 0.0)))
448        (:fixed-font (setq font (#/userFixedPitchFontOfSize: ns:ns-font 0.0)))
449        (:system-font (setq font (#/systemFontOfSize: ns:ns-font 0.0)))
450        (t (setq font (#/fontWithName:size: ns:ns-font
451                                            (#/autorelease (%make-nsstring font-name))
452                                            0.0)))))
453    (when (%null-ptr-p font)
454      (setq font default-font))
455    (loop for (k v) on plist by #'cddr
456      do (case k
457           (:font-size
458            (setq v (float v ns:+cgfloat-zero+))
459            (setq font (#/convertFont:toSize: fm font v)))
460           (:font-weight
461            (cond
462              ((eq v :bold)
463               (setq font (#/convertFont:toHaveTrait: fm font #$NSBoldFontMask)))
464              ((eq v :plain)
465               (setq font (#/convertFont:toHaveTrait: fm font #$NSUnboldFontMask)))))
466           (:font-width
467            (cond
468              ((eq v :condensed)
469               (setq font (#/convertFont:toHaveTrait: fm font #$NSCondensedFontMask)))
470              ((eq v :expanded)
471               (setq font (#/convertFont:toHaveTrait: fm font #$NSExpandedFontMask)))))
472           (:font-slant
473            (cond ((eq v :italic)
474                   (setq font (#/convertFont:toHaveTrait: fm font #$NSItalicFontMask)))
475                  ((eq v :roman)
476                   (setq font (#/convertFont:toHaveTrait: fm font #$NSUnitalicFontMask)))))
477           (:font-underline
478            (let (n)
479              (case v
480                (:single
481                 (setq n (#/numberWithInt: ns:ns-number #$NSUnderlineStyleSingle)))
482                (:double
483                 (setq n (#/numberWithInt: ns:ns-number #$NSUnderlineStyleDouble)))
484                (:thick
485                 (setq n (#/numberWithInt: ns:ns-number #$NSUnderlineStyleThick))))
486              (when n
487                (#/setObject:forKey: dict n #&NSUnderlineStyleAttributeName))))
488           (:font-color
489            (let ((color (ns-color-from-charprop v)))
490              (when color
491                (#/setObject:forKey: dict color #&NSForegroundColorAttributeName))))
492           (:background-color
493            (let ((color (ns-color-from-charprop v)))
494              (when color
495                (#/setObject:forKey: dict color #&NSBackgroundColorAttributeName))))))
496    (unless (%null-ptr-p font)
497      (#/setObject:forKey: dict font #&NSFontAttributeName))
498    dict))
499
500(defclass xhemlock-text-view (ns:ns-text-view)
501  ()
502  (:metaclass ns:+ns-object))
503
504;;; replaces version in cocoa-editor.lisp
505
506(defun make-textstorage-for-hemlock-buffer (buffer)
507  (make-instance 'xhemlock-text-storage
508                 :with-string
509                 (make-instance
510                  'xhemlock-buffer-string
511                  :cache
512                  (reset-buffer-cache
513                   (make-buffer-cache)
514                   buffer))))
Note: See TracBrowser for help on using the repository browser.