;;;-*-Mode: LISP; Package: GUI -*- ;;; ;;; Copyright (C) 2007 Clozure Associates (in-package "GUI") ;;; In the double-float case, this is probably way too small. ;;; Traditionally, it's (approximately) the point at which ;;; a single-float stops being able to accurately represent ;;; integral values. (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant large-number-for-text (cgfloat 1.0f7))) (def-cocoa-default *editor-font* :font #'(lambda () (#/fontWithName:size: ns:ns-font #@"Monaco" 10.0)) "Default font for editor windows") (def-cocoa-default *editor-rows* :int 24 "Initial height of editor windows, in characters") (def-cocoa-default *editor-columns* :int 80 "Initial width of editor windows, in characters") (def-cocoa-default *editor-background-color* :color '(1.0 1.0 1.0 1.0) "Editor background color") (def-cocoa-default *wrap-lines-to-window* :bool nil "Soft wrap lines to window width") (def-cocoa-default *use-screen-fonts* :bool t "Use bitmap screen fonts when available") (defgeneric hemlock-view (ns-object)) (defmethod hemlock-view ((unknown t)) nil) (defgeneric hemlock-buffer (ns-object)) (defmethod hemlock-buffer ((unknown t)) (let ((view (hemlock-view unknown))) (when view (hi::hemlock-view-buffer view)))) (defmacro nsstring-encoding-to-nsinteger (n) (ccl::target-word-size-case (32 `(ccl::u32->s32 ,n)) (64 n))) (defmacro nsinteger-to-nsstring-encoding (n) (ccl::target-word-size-case (32 `(ccl::s32->u32 ,n)) (64 n))) ;;; Create a paragraph style, mostly so that we can set tabs reasonably. (defun rme-create-paragraph-style (font line-break-mode) (let* ((p (make-instance 'ns:ns-mutable-paragraph-style)) (charwidth (fround (nth-value 1 (size-of-char-in-font font))))) (#/setLineBreakMode: p (ecase line-break-mode (:char #$NSLineBreakByCharWrapping) (:word #$NSLineBreakByWordWrapping) ;; This doesn't seem to work too well. ((nil) #$NSLineBreakByClipping))) ;; Clear existing tab stops. (#/setTabStops: p (#/array ns:ns-array)) ;; And set the "default tab interval". (#/setDefaultTabInterval: p (* *tab-width* charwidth)) p)) (defun rme-create-text-attributes (&key (font *editor-font*) (line-break-mode :char) (color nil) (obliqueness nil) (stroke-width nil)) (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 5))) (#/setObject:forKey: dict (rme-create-paragraph-style font line-break-mode) #&NSParagraphStyleAttributeName) (#/setObject:forKey: dict font #&NSFontAttributeName) (when color (#/setObject:forKey: dict color #&NSForegroundColorAttributeName)) (when stroke-width (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number stroke-width) #&NSStrokeWidthAttributeName)) (when obliqueness (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number obliqueness) #&NSObliquenessAttributeName)) dict)) (defun rme-make-editor-style-map () (let* ((font *editor-font*) (fm (#/sharedFontManager ns:ns-font-manager)) (bold-font (#/convertFont:toHaveTrait: fm font #$NSBoldFontMask)) (oblique-font (#/convertFont:toHaveTrait: fm font #$NSItalicFontMask)) (bold-oblique-font (#/convertFont:toHaveTrait: fm font (logior #$NSItalicFontMask #$NSBoldFontMask))) (colors (vector (#/blackColor ns:ns-color))) (fonts (vector font bold-font oblique-font bold-oblique-font)) (styles (make-instance 'ns:ns-mutable-array))) (dotimes (c (length colors)) (dotimes (i 4) (let* ((mask (logand i 3)) (f (svref fonts mask))) (#/addObject: styles (rme-create-text-attributes :font f :color (svref colors c) :obliqueness (if (logbitp 1 i) (when (eql f font) 0.15f0)) :stroke-width (if (logbitp 0 i) (when (eql f font) -10.0f0))))))) styles)) (defun make-editor-style-map () (rme-make-editor-style-map)) #+nil (defun make-editor-style-map () (let* ((font-name *default-font-name*) (font-size *default-font-size*) (font (default-font :name font-name :size font-size)) (bold-font (let* ((f (default-font :name font-name :size font-size :attributes '(:bold)))) (unless (eql f font) f))) (oblique-font (let* ((f (default-font :name font-name :size font-size :attributes '(:italic)))) (unless (eql f font) f))) (bold-oblique-font (let* ((f (default-font :name font-name :size font-size :attributes '(:bold :italic)))) (unless (eql f font) f))) (color-class (find-class 'ns:ns-color)) (colors (vector (#/blackColor color-class))) (styles (make-instance 'ns:ns-mutable-array :with-capacity (the fixnum (* 4 (length colors))))) (bold-stroke-width -10.0f0) (fonts (vector font (or bold-font font) (or oblique-font font) (or bold-oblique-font font))) (real-fonts (vector font bold-font oblique-font bold-oblique-font)) (s 0)) (declare (dynamic-extent fonts real-fonts colors)) (dotimes (c (length colors)) (dotimes (i 4) (let* ((mask (logand i 3))) (#/addObject: styles (create-text-attributes :font (svref fonts mask) :color (svref colors c) :obliqueness (if (logbitp 1 i) (unless (svref real-fonts mask) 0.15f0)) :stroke-width (if (logbitp 0 i) (unless (svref real-fonts mask) bold-stroke-width))))) (incf s))) (#/retain styles))) (defun make-hemlock-buffer (&rest args) (let* ((buf (apply #'hi::make-buffer args))) (assert buf) buf)) ;;; Define some key event modifiers and keysym codes (hi:define-modifier-bit #$NSShiftKeyMask "Shift") (hi:define-modifier-bit #$NSControlKeyMask "Control") (hi:define-modifier-bit #$NSAlternateKeyMask "Meta") (hi:define-modifier-bit #$NSAlphaShiftKeyMask "Lock") (hi:define-keysym-code :F1 #$NSF1FunctionKey) (hi:define-keysym-code :F2 #$NSF2FunctionKey) (hi:define-keysym-code :F3 #$NSF3FunctionKey) (hi:define-keysym-code :F4 #$NSF4FunctionKey) (hi:define-keysym-code :F5 #$NSF5FunctionKey) (hi:define-keysym-code :F6 #$NSF6FunctionKey) (hi:define-keysym-code :F7 #$NSF7FunctionKey) (hi:define-keysym-code :F8 #$NSF8FunctionKey) (hi:define-keysym-code :F9 #$NSF9FunctionKey) (hi:define-keysym-code :F10 #$NSF10FunctionKey) (hi:define-keysym-code :F11 #$NSF11FunctionKey) (hi:define-keysym-code :F12 #$NSF12FunctionKey) (hi:define-keysym-code :F13 #$NSF13FunctionKey) (hi:define-keysym-code :F14 #$NSF14FunctionKey) (hi:define-keysym-code :F15 #$NSF15FunctionKey) (hi:define-keysym-code :F16 #$NSF16FunctionKey) (hi:define-keysym-code :F17 #$NSF17FunctionKey) (hi:define-keysym-code :F18 #$NSF18FunctionKey) (hi:define-keysym-code :F19 #$NSF19FunctionKey) (hi:define-keysym-code :F20 #$NSF20FunctionKey) (hi:define-keysym-code :F21 #$NSF21FunctionKey) (hi:define-keysym-code :F22 #$NSF22FunctionKey) (hi:define-keysym-code :F23 #$NSF23FunctionKey) (hi:define-keysym-code :F24 #$NSF24FunctionKey) (hi:define-keysym-code :F25 #$NSF25FunctionKey) (hi:define-keysym-code :F26 #$NSF26FunctionKey) (hi:define-keysym-code :F27 #$NSF27FunctionKey) (hi:define-keysym-code :F28 #$NSF28FunctionKey) (hi:define-keysym-code :F29 #$NSF29FunctionKey) (hi:define-keysym-code :F30 #$NSF30FunctionKey) (hi:define-keysym-code :F31 #$NSF31FunctionKey) (hi:define-keysym-code :F32 #$NSF32FunctionKey) (hi:define-keysym-code :F33 #$NSF33FunctionKey) (hi:define-keysym-code :F34 #$NSF34FunctionKey) (hi:define-keysym-code :F35 #$NSF35FunctionKey) ;;; Upper right key bank. ;;; (hi:define-keysym-code :Printscreen #$NSPrintScreenFunctionKey) ;; Couldn't type scroll lock. (hi:define-keysym-code :Pause #$NSPauseFunctionKey) ;;; Middle right key bank. ;;; (hi:define-keysym-code :Insert #$NSInsertFunctionKey) (hi:define-keysym-code :Del #$NSDeleteFunctionKey) (hi:define-keysym-code :Home #$NSHomeFunctionKey) (hi:define-keysym-code :Pageup #$NSPageUpFunctionKey) (hi:define-keysym-code :End #$NSEndFunctionKey) (hi:define-keysym-code :Pagedown #$NSPageDownFunctionKey) ;;; Arrows. ;;; (hi:define-keysym-code :Leftarrow #$NSLeftArrowFunctionKey) (hi:define-keysym-code :Uparrow #$NSUpArrowFunctionKey) (hi:define-keysym-code :Downarrow #$NSDownArrowFunctionKey) (hi:define-keysym-code :Rightarrow #$NSRightArrowFunctionKey) ;;; ;(hi:define-keysym-code :linefeed 65290) ;;; We want to display a Hemlock buffer in a "pane" (an on-screen ;;; view) which in turn is presented in a "frame" (a Cocoa window). A ;;; 1:1 mapping between frames and panes seems to fit best into ;;; Cocoa's document architecture, but we should try to keep the ;;; concepts separate (in case we come up with better UI paradigms.) ;;; Each pane has a modeline (which describes attributes of the ;;; underlying document); each frame has an echo area (which serves ;;; to display some commands' output and to provide multi-character ;;; input.) ;;; I'd pretty much concluded that it wouldn't be possible to get the ;;; Cocoa text system (whose storage model is based on NSString ;;; NSMutableAttributedString, NSTextStorage, etc.) to get along with ;;; Hemlock, and (since the whole point of using Hemlock was to be ;;; able to treat an editor buffer as a rich lisp data structure) it ;;; seemed like it'd be necessary to toss the higher-level Cocoa text ;;; system and implement our own scrolling, redisplay, selection ;;; ... code. ;;; ;;; Mikel Evins pointed out that NSString and friends were ;;; abstract classes and that there was therefore no reason (in ;;; theory) not to implement a thin wrapper around a Hemlock buffer ;;; that made it act like an NSString. As long as the text system can ;;; ask a few questions about the NSString (its length and the ;;; character and attributes at a given location), it's willing to ;;; display the string in a scrolling, mouse-selectable NSTextView; ;;; as long as Hemlock tells the text system when and how the contents ;;; of the abstract string changes, Cocoa will handle the redisplay ;;; details. ;;; ;;; Hemlock-buffer-string objects: (defclass hemlock-buffer-string (ns:ns-string) ((cache :initform nil :initarg :cache :accessor hemlock-buffer-string-cache)) (:metaclass ns:+ns-object)) (defmethod hemlock-buffer ((self hemlock-buffer-string)) (let ((cache (hemlock-buffer-string-cache self))) (when cache (hemlock-buffer cache)))) ;;; Cocoa wants to treat the buffer as a linear array of characters; ;;; Hemlock wants to treat it as a doubly-linked list of lines, so ;;; we often have to map between an absolute position in the buffer ;;; and a relative position on a line. We can certainly do that ;;; by counting the characters in preceding lines every time that we're ;;; asked, but we're often asked to map a sequence of nearby positions ;;; and wind up repeating a lot of work. Caching the results of that ;;; work seems to speed things up a bit in many cases; this data structure ;;; is used in that process. (It's also the only way to get to the ;;; actual underlying Lisp buffer from inside the network of text-system ;;; objects.) (defstruct buffer-cache buffer ; the hemlock buffer buflen ; length of buffer, if known workline ; cache for character-at-index workline-offset ; cached offset of workline workline-length ; length of cached workline workline-start-font-index ; current font index at start of workline ) (defmethod hemlock-buffer ((self buffer-cache)) (buffer-cache-buffer self)) ;;; Initialize (or reinitialize) a buffer cache, so that it points ;;; to the buffer's first line (which is the only line whose ;;; absolute position will never change). Code which modifies the ;;; buffer generally has to call this, since any cached information ;;; might be invalidated by the modification. (defun reset-buffer-cache (d &optional (buffer (buffer-cache-buffer d) buffer-p)) (when buffer-p (setf (buffer-cache-buffer d) buffer)) (let* ((hi::*current-buffer* buffer) (workline (hi::mark-line (hi::buffer-start-mark buffer)))) (setf (buffer-cache-buflen d) (hemlock-buffer-length buffer) (buffer-cache-workline-offset d) 0 (buffer-cache-workline d) workline (buffer-cache-workline-length d) (hi::line-length workline) (buffer-cache-workline-start-font-index d) 0) d)) (defun adjust-buffer-cache-for-insertion (display pos n) (if (buffer-cache-workline display) (let* ((hi::*current-buffer* (buffer-cache-buffer display))) (if (> (buffer-cache-workline-offset display) pos) (incf (buffer-cache-workline-offset display) n) (when (>= (+ (buffer-cache-workline-offset display) (buffer-cache-workline-length display)) pos) (setf (buffer-cache-workline-length display) (hi::line-length (buffer-cache-workline display))))) (incf (buffer-cache-buflen display) n)) (reset-buffer-cache display))) ;;; Update the cache so that it's describing the current absolute ;;; position. (defun update-line-cache-for-index (cache index) (let* ((buffer (buffer-cache-buffer cache)) (hi::*current-buffer* buffer) (line (or (buffer-cache-workline cache) (progn (reset-buffer-cache cache) (buffer-cache-workline cache)))) (pos (buffer-cache-workline-offset cache)) (len (buffer-cache-workline-length cache)) (moved nil)) (loop (when (and (>= index pos) (< index (1+ (+ pos len)))) (let* ((idx (- index pos))) (when moved (setf (buffer-cache-workline cache) line (buffer-cache-workline-offset cache) pos (buffer-cache-workline-length cache) len)) (return (values line idx)))) (setq moved t) (if (< index pos) (setq line (hi::line-previous line) len (hi::line-length line) pos (1- (- pos len))) (setq line (hi::line-next line) pos (1+ (+ pos len)) len (hi::line-length line)))))) ;;; Ask Hemlock to count the characters in the buffer. (defun hemlock-buffer-length (buffer) (let* ((hi::*current-buffer* buffer)) (hemlock::count-characters (hemlock::buffer-region buffer)))) ;;; Find the line containing (or immediately preceding) index, which is ;;; assumed to be less than the buffer's length. Return the character ;;; in that line or the trailing #\newline, as appropriate. (defun hemlock-char-at-index (cache index) (let* ((hi::*current-buffer* (buffer-cache-buffer cache))) (multiple-value-bind (line idx) (update-line-cache-for-index cache index) (let* ((len (hemlock::line-length line))) (if (< idx len) (hemlock::line-character line idx) #\newline))))) ;;; Given an absolute position, move the specified mark to the appropriate ;;; offset on the appropriate line. (defun move-hemlock-mark-to-absolute-position (mark cache abspos) ;; TODO: figure out if updating the cache matters, and if not, use hi:move-to-absolute-position. (let* ((hi::*current-buffer* (buffer-cache-buffer cache))) (multiple-value-bind (line idx) (update-line-cache-for-index cache abspos) #+debug (#_NSLog #@"Moving point from current pos %d to absolute position %d" :int (hi:mark-absolute-position mark) :int abspos) (hemlock::move-to-position mark idx line) #+debug (#_NSLog #@"Moved mark to %d" :int (hi:mark-absolute-position mark))))) ;;; Return the length of the abstract string, i.e., the number of ;;; characters in the buffer (including implicit newlines.) (objc:defmethod (#/length :nteger) ((self hemlock-buffer-string)) (let* ((cache (hemlock-buffer-string-cache self))) (or (buffer-cache-buflen cache) (setf (buffer-cache-buflen cache) (let* ((buffer (buffer-cache-buffer cache))) (hemlock-buffer-length buffer)))))) ;;; Return the character at the specified index (as a :unichar.) (objc:defmethod (#/characterAtIndex: :unichar) ((self hemlock-buffer-string) (index :nteger)) #+debug (#_NSLog #@"Character at index: %d" :nteger index) (char-code (hemlock-char-at-index (hemlock-buffer-string-cache self) index))) (objc:defmethod (#/getCharacters:range: :void) ((self hemlock-buffer-string) (buffer (:* :unichar)) (r :ange)) (let* ((cache (hemlock-buffer-string-cache self)) (index (ns:ns-range-location r)) (length (ns:ns-range-length r)) (hi::*current-buffer* (buffer-cache-buffer cache))) #+debug (#_NSLog #@"get characters: %d/%d" :nteger index :nteger length) (multiple-value-bind (line idx) (update-line-cache-for-index cache index) (let* ((len (hemlock::line-length line))) (do* ((i 0 (1+ i))) ((= i length)) (cond ((< idx len) (setf (paref buffer (:* :unichar) i) (char-code (hemlock::line-character line idx))) (incf idx)) (t (setf (paref buffer (:* :unichar) i) (char-code #\Newline) line (hi::line-next line) len (if line (hi::line-length line) 0) idx 0)))))))) (objc:defmethod (#/getLineStart:end:contentsEnd:forRange: :void) ((self hemlock-buffer-string) (startptr (:* :nteger)) (endptr (:* :nteger)) (contents-endptr (:* :nteger)) (r :ange)) (let* ((cache (hemlock-buffer-string-cache self)) (index (pref r :ange.location)) (length (pref r :ange.length)) (hi::*current-buffer* (buffer-cache-buffer cache))) #+debug (#_NSLog #@"get line start: %d/%d" :unsigned index :unsigned length) (update-line-cache-for-index cache index) (unless (%null-ptr-p startptr) ;; Index of the first character in the line which contains ;; the start of the range. (setf (pref startptr :nteger) (buffer-cache-workline-offset cache))) (unless (%null-ptr-p endptr) ;; Index of the newline which terminates the line which ;; contains the start of the range. (setf (pref endptr :nteger) (+ (buffer-cache-workline-offset cache) (buffer-cache-workline-length cache)))) (unless (%null-ptr-p contents-endptr) ;; Index of the newline which terminates the line which ;; contains the start of the range. (unless (zerop length) (update-line-cache-for-index cache (+ index length))) (setf (pref contents-endptr :nteger) (1+ (+ (buffer-cache-workline-offset cache) (buffer-cache-workline-length cache))))))) ;;; For debugging, mostly: make the printed representation of the string ;;; referenence the named Hemlock buffer. (objc:defmethod #/description ((self hemlock-buffer-string)) (let* ((cache (hemlock-buffer-string-cache self)) (b (buffer-cache-buffer cache))) (with-cstrs ((s (format nil "~a" b))) (#/stringWithFormat: ns:ns-string #@"<%s for %s>" (#_object_getClassName self) s)))) ;;; hemlock-text-storage objects (defclass hemlock-text-storage (ns:ns-text-storage) ((string :foreign-type :id) (hemlock-string :foreign-type :id) (edit-count :foreign-type :int) (mirror :foreign-type :id) (styles :foreign-type :id) (selection-set-by-search :foreign-type :)) (:metaclass ns:+ns-object)) (declaim (special hemlock-text-storage)) (defmethod hemlock-buffer ((self hemlock-text-storage)) (let ((string (slot-value self 'hemlock-string))) (unless (%null-ptr-p string) (hemlock-buffer string)))) ;;; This is only here so that calls to it can be logged for debugging. #+debug (objc:defmethod (#/lineBreakBeforeIndex:withinRange: :nteger) ((self hemlock-text-storage) (index :nteger) (r :ange)) (#_NSLog #@"Line break before index: %d within range: %@" :unsigned index :id (#_NSStringFromRange r)) (call-next-method index r)) ;;; Return true iff we're inside a "beginEditing/endEditing" pair (objc:defmethod (#/editingInProgress :) ((self hemlock-text-storage)) ;; This is meaningless outside the event thread, since you can't tell what ;; other edit-count changes have already been queued up for execution on ;; the event thread before it gets to whatever you might queue up next. (assume-cocoa-thread) (> (slot-value self 'edit-count) 0)) (defmethod assume-not-editing ((ts hemlock-text-storage)) #+debug NIL (assert (eql (slot-value ts 'edit-count) 0))) (defun textstorage-note-insertion-at-position (self pos n) (ns:with-ns-range (r pos 0) (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes r n) (setf (ns:ns-range-length r) n) (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters r 0))) ;;; This runs on the main thread; it synchronizes the "real" NSMutableAttributedString ;;; with the hemlock string and informs the textstorage of the insertion. (objc:defmethod (#/noteHemlockInsertionAtPosition:length: :void) ((self hemlock-text-storage) (pos :nteger) (n :nteger) (extra :nteger)) (declare (ignorable extra)) (assume-cocoa-thread) (let* ((mirror (#/mirror self)) (hemlock-string (#/hemlockString self)) (display (hemlock-buffer-string-cache hemlock-string)) (buffer (buffer-cache-buffer display)) (hi::*current-buffer* buffer) (attributes (buffer-active-font-attributes buffer)) (document (#/document self)) (undo-mgr (and document (#/undoManager document)))) #+debug (#_NSLog #@"insert: pos = %ld, n = %ld" :long pos :long n) ;; We need to update the hemlock string mirror here so that #/substringWithRange: ;; will work on the hemlock buffer string. (adjust-buffer-cache-for-insertion display pos n) (update-line-cache-for-index display pos) (let* ((replacestring (#/substringWithRange: hemlock-string (ns:make-ns-range pos n)))) (ns:with-ns-range (replacerange pos 0) (#/replaceCharactersInRange:withString: mirror replacerange replacestring)) (when (and undo-mgr (not (#/isUndoing undo-mgr))) (#/replaceCharactersAtPosition:length:withString: (#/prepareWithInvocationTarget: undo-mgr self) pos n #@""))) (#/setAttributes:range: mirror attributes (ns:make-ns-range pos n)) (textstorage-note-insertion-at-position self pos n))) (objc:defmethod (#/noteHemlockDeletionAtPosition:length: :void) ((self hemlock-text-storage) (pos :nteger) (n :nteger) (extra :nteger)) (declare (ignorable extra)) #+debug (#_NSLog #@"delete: pos = %ld, n = %ld" :long pos :long n) (ns:with-ns-range (range pos n) (let* ((mirror (#/mirror self)) (deleted-string (#/substringWithRange: (#/string mirror) range)) (document (#/document self)) (undo-mgr (and document (#/undoManager document))) (display (hemlock-buffer-string-cache (#/hemlockString self)))) ;; It seems to be necessary to call #/edited:range:changeInLength: before ;; deleting from the mirror attributed string. It's not clear whether this ;; is also true of insertions and modifications. (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters #$NSTextStorageEditedAttributes) range (- n)) (#/deleteCharactersInRange: mirror range) (when (and undo-mgr (not (#/isUndoing undo-mgr))) (#/replaceCharactersAtPosition:length:withString: (#/prepareWithInvocationTarget: undo-mgr self) pos 0 deleted-string)) (reset-buffer-cache display) (update-line-cache-for-index display pos)))) (objc:defmethod (#/noteHemlockModificationAtPosition:length: :void) ((self hemlock-text-storage) (pos :nteger) (n :nteger) (extra :nteger)) (declare (ignorable extra)) #+debug (#_NSLog #@"modify: pos = %ld, n = %ld" :long pos :long n) (ns:with-ns-range (range pos n) (let* ((hemlock-string (#/hemlockString self)) (mirror (#/mirror self)) (deleted-string (#/substringWithRange: (#/string mirror) range)) (document (#/document self)) (undo-mgr (and document (#/undoManager document)))) (#/replaceCharactersInRange:withString: mirror range (#/substringWithRange: hemlock-string range)) (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters #$NSTextStorageEditedAttributes) range 0) (when (and undo-mgr (not (#/isUndoing undo-mgr))) (#/replaceCharactersAtPosition:length:withString: (#/prepareWithInvocationTarget: undo-mgr self) pos n deleted-string))))) (objc:defmethod (#/noteHemlockAttrChangeAtPosition:length: :void) ((self hemlock-text-storage) (pos :nteger) (n :nteger) (fontnum :nteger)) (ns:with-ns-range (range pos n) (#/setAttributes:range: (#/mirror self) (#/objectAtIndex: (#/styles self) fontnum) range) (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes range 0))) (defloadvar *buffer-change-invocation* (with-autorelease-pool (#/retain (#/invocationWithMethodSignature: ns:ns-invocation (#/instanceMethodSignatureForSelector: hemlock-text-storage (@selector #/noteHemlockInsertionAtPosition:length:)))))) (defstatic *buffer-change-invocation-lock* (make-lock)) (objc:defmethod (#/beginEditing :void) ((self hemlock-text-storage)) (assume-cocoa-thread) (with-slots (edit-count) self #+debug (#_NSLog #@"begin-editing") (incf edit-count) #+debug (#_NSLog #@"after beginEditing on %@ edit-count now = %d" :id self :int edit-count) (call-next-method))) (objc:defmethod (#/endEditing :void) ((self hemlock-text-storage)) (assume-cocoa-thread) (with-slots (edit-count) self #+debug (#_NSLog #@"end-editing") (call-next-method) (assert (> edit-count 0)) (decf edit-count) #+debug (#_NSLog #@"after endEditing on %@, edit-count now = %d" :id self :int edit-count))) ;;; Access the string. It'd be nice if this was a generic function; ;;; we could have just made a reader method in the class definition. (objc:defmethod #/string ((self hemlock-text-storage)) (slot-value self 'string)) (objc:defmethod #/mirror ((self hemlock-text-storage)) (slot-value self 'mirror)) (objc:defmethod #/hemlockString ((self hemlock-text-storage)) (slot-value self 'hemlock-string)) (objc:defmethod #/styles ((self hemlock-text-storage)) (slot-value self 'styles)) (objc:defmethod #/document ((self hemlock-text-storage)) (or (let* ((string (#/hemlockString self))) (unless (%null-ptr-p string) (let* ((cache (hemlock-buffer-string-cache string))) (when cache (let* ((buffer (buffer-cache-buffer cache))) (when buffer (hi::buffer-document buffer))))))) +null-ptr+)) (objc:defmethod #/initWithString: ((self hemlock-text-storage) s) (setq s (%inc-ptr s 0)) (let* ((newself (#/init self)) (styles (make-editor-style-map)) (mirror (#/retain (make-instance ns:ns-mutable-attributed-string :with-string s :attributes (#/objectAtIndex: styles 0))))) (declare (type hemlock-text-storage newself)) (setf (slot-value newself 'styles) styles) (setf (slot-value newself 'hemlock-string) s) (setf (slot-value newself 'mirror) mirror) (setf (slot-value newself 'string) (#/retain (#/string mirror))) newself)) ;;; Should generally only be called after open/revert. (objc:defmethod (#/updateMirror :void) ((self hemlock-text-storage)) (with-slots (hemlock-string mirror styles) self (#/replaceCharactersInRange:withString: mirror (ns:make-ns-range 0 (#/length mirror)) hemlock-string) (#/setAttributes:range: mirror (#/objectAtIndex: styles 0) (ns:make-ns-range 0 (#/length mirror))))) ;;; This is the only thing that's actually called to create a ;;; hemlock-text-storage object. (It also creates the underlying ;;; hemlock-buffer-string.) (defun make-textstorage-for-hemlock-buffer (buffer) (make-instance 'hemlock-text-storage :with-string (make-instance 'hemlock-buffer-string :cache (reset-buffer-cache (make-buffer-cache) buffer)))) (objc:defmethod #/attributesAtIndex:effectiveRange: ((self hemlock-text-storage) (index :nteger) (rangeptr (* :ange))) #+debug (#_NSLog #@"Attributes at index: %lu storage %@" :nteger index :id self) (with-slots (mirror styles) self (when (>= index (#/length mirror)) (#_NSLog #@"Bounds error - Attributes at index: %lu edit-count: %d mirror: %@ layout: %@" :nteger index ::unsigned (slot-value self 'edit-count) :id mirror :id (#/objectAtIndex: (#/layoutManagers self) 0)) (ccl::dbg)) (let* ((attrs (#/attributesAtIndex:effectiveRange: mirror index rangeptr))) (when (eql 0 (#/count attrs)) (#_NSLog #@"No attributes ?") (ns:with-ns-range (r) (#/attributesAtIndex:longestEffectiveRange:inRange: mirror index r (ns:make-ns-range 0 (#/length mirror))) (setq attrs (#/objectAtIndex: styles 0)) (#/setAttributes:range: mirror attrs r))) attrs))) (objc:defmethod (#/replaceCharactersAtPosition:length:withString: :void) ((self hemlock-text-storage) (pos nteger) (len nteger) string) (let* ((document (#/document self)) (undo-mgr (and document (#/undoManager document)))) (when (and undo-mgr (not (#/isRedoing undo-mgr))) (let ((replaced-string (#/substringWithRange: (#/hemlockString self) (ns:make-ns-range pos len)))) (#/replaceCharactersAtPosition:length:withString: (#/prepareWithInvocationTarget: undo-mgr self) pos (#/length string) replaced-string))) (ns:with-ns-range (r pos len) (#/replaceCharactersInRange:withString: self r string)))) ;; In theory (though not yet in practice) we allow for a buffer to be shown in multiple ;; windows, and any change to a buffer through one window has to be reflected in all of ;; them. Once hemlock really supports multiple views of a buffer, it will have some ;; mechanims to ensure that. ;; In Cocoa, we get some messages for the buffer (i.e. the document or the textstorage) ;; with no reference to a view. There used to be code here that tried to do special- ;; case stuff for all views on the buffer, but that's not necessary, because as long ;; as hemlock doesn't support it, there will only be one view, and as soon as hemlock ;; does support it, will take care of updating all other views. So all we need is to ;; get our hands on one of the views and do whatever it is through it. (defun front-view-for-buffer (buffer) (loop with win-arr = (#/orderedWindows *NSApp*) for i from 0 below (#/count win-arr) as w = (#/objectAtIndex: win-arr i) thereis (and (eq (hemlock-buffer w) buffer) (hemlock-view w)))) (objc:defmethod (#/replaceCharactersInRange:withString: :void) ((self hemlock-text-storage) (r :ange) string) (let* ((buffer (hemlock-buffer self)) (position (pref r :ange.location)) (length (pref r :ange.length)) (lisp-string (if (> (#/length string) 0) (lisp-string-from-nsstring string))) (view (front-view-for-buffer buffer))) (when view (hi::handle-hemlock-event view #'(lambda () (hi:paste-characters position length lisp-string)))))) (objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage) attributes (r :ange)) #+debug (#_NSLog #@"Set attributes: %@ at %d/%d" :id attributes :int (pref r :ange.location) :int (pref r :ange.length)) (with-slots (mirror) self (#/setAttributes:range: mirror attributes r) #+debug (#_NSLog #@"Assigned attributes = %@" :id (#/attributesAtIndex:effectiveRange: mirror (pref r :ange.location) +null-ptr+)))) (defun for-each-textview-using-storage (textstorage f) (let* ((layouts (#/layoutManagers textstorage))) (unless (%null-ptr-p layouts) (dotimes (i (#/count layouts)) (let* ((layout (#/objectAtIndex: layouts i)) (containers (#/textContainers layout))) (unless (%null-ptr-p containers) (dotimes (j (#/count containers)) (let* ((container (#/objectAtIndex: containers j)) (tv (#/textView container))) (funcall f tv))))))))) ;;; Again, it's helpful to see the buffer name when debugging. (objc:defmethod #/description ((self hemlock-text-storage)) (#/stringWithFormat: ns:ns-string #@"%s : string %@" (#_object_getClassName self) (slot-value self 'hemlock-string))) (defun close-hemlock-textstorage (ts) (declare (type hemlock-text-storage ts)) (with-slots (styles) ts (#/release styles) (setq styles +null-ptr+)) (let* ((hemlock-string (slot-value ts 'hemlock-string))) (setf (slot-value ts 'hemlock-string) +null-ptr+) (unless (%null-ptr-p hemlock-string) (let* ((cache (hemlock-buffer-string-cache hemlock-string)) (buffer (if cache (buffer-cache-buffer cache)))) (when buffer (setf (buffer-cache-buffer cache) nil (slot-value hemlock-string 'cache) nil (hi::buffer-document buffer) nil) (when (eq buffer hi::*current-buffer*) (setf hi::*current-buffer* nil)) (hi::delete-buffer buffer)))))) ;;; Mostly experimental, so that we can see what happens when a ;;; real typesetter is used. (defclass hemlock-ats-typesetter (ns:ns-ats-typesetter) () (:metaclass ns:+ns-object)) (objc:defmethod (#/layoutGlyphsInLayoutManager:startingAtGlyphIndex:maxNumberOfLineFragments:nextGlyphIndex: :void) ((self hemlock-ats-typesetter) layout-manager (start-index :nteger) (max-lines :nteger) (next-index (:* :nteger))) (#_NSLog #@"layoutGlyphs: start = %d, maxlines = %d" :int start-index :int max-lines) (call-next-method layout-manager start-index max-lines next-index)) ;;; An abstract superclass of the main and echo-area text views. (defclass hemlock-textstorage-text-view (ns::ns-text-view) ((blink-location :foreign-type :unsigned :accessor text-view-blink-location) (blink-color-attribute :foreign-type :id :accessor text-view-blink-color) (blink-enabled :foreign-type : :accessor text-view-blink-enabled) (peer :foreign-type :id)) (:metaclass ns:+ns-object)) (declaim (special hemlock-textstorage-text-view)) (defmethod hemlock-view ((self hemlock-textstorage-text-view)) (let ((frame (#/window self))) (unless (%null-ptr-p frame) (hemlock-view frame)))) (defmethod activate-hemlock-view ((self hemlock-textstorage-text-view)) (assume-cocoa-thread) (let* ((the-hemlock-frame (#/window self))) #+debug (log-debug "Activating ~s" self) (with-slots ((echo peer)) self (deactivate-hemlock-view echo)) (#/setEditable: self t) (#/makeFirstResponder: the-hemlock-frame self))) (defmethod deactivate-hemlock-view ((self hemlock-textstorage-text-view)) (assume-cocoa-thread) #+debug (log-debug "deactivating ~s" self) (assume-not-editing self) (#/setSelectable: self nil)) (defmethod eventqueue-abort-pending-p ((self hemlock-textstorage-text-view)) ;; Return true if cmd-. is in the queue. Not sure what to do about c-g: ;; would have to distinguish c-g from c-q c-g or c-q c-q c-g etc.... Maybe ;; c-g will need to be synchronous meaning just end current command, ;; while cmd-. is the real abort. #| (let* ((now (#/dateWithTimeIntervalSinceNow: ns:ns-date 0.0d0))) (loop (let* ((event (#/nextEventMatchingMask:untilDate:inMode:dequeue: target (logior #$whatever) now #&NSDefaultRunLoopMode t))) (when (%null-ptr-p event) (return))))) "target" can either be an NSWindow or the global shared application object; |# nil) (defvar *buffer-being-edited* nil) (objc:defmethod (#/keyDown: :void) ((self hemlock-textstorage-text-view) event) #+debug (#_NSLog #@"Key down event = %@" :address event) (let* ((view (hemlock-view self)) ;; quote-p means handle characters natively (quote-p (and view (hi::hemlock-view-quote-next-p view)))) #+GZ (log-debug "~"e-p ~s event ~s" quote-p event) (if (or (null view) (#/hasMarkedText self) (and quote-p (zerop (#/length (#/characters event))))) ;; dead key, e.g. option-E (call-next-method event) (unless (eventqueue-abort-pending-p self) (let ((hemlock-key (nsevent-to-key-event event quote-p))) (when hemlock-key (hi::handle-hemlock-event view hemlock-key))))))) (defmethod hi::handle-hemlock-event :around ((view hi:hemlock-view) event) (declare (ignore event)) (with-autorelease-pool (call-next-method))) (defconstant +shift-event-mask+ (hi:key-event-modifier-mask "Shift")) ;;; Translate a keyDown NSEvent to a Hemlock key-event. (defun nsevent-to-key-event (event quote-p) (let* ((modifiers (#/modifierFlags event))) (unless (logtest #$NSCommandKeyMask modifiers) (let* ((chars (if quote-p (#/characters event) (#/charactersIgnoringModifiers event))) (n (if (%null-ptr-p chars) 0 (#/length chars))) (c (and (eql n 1) (#/characterAtIndex: chars 0)))) (when c (let* ((bits 0) (useful-modifiers (logandc2 modifiers (logior ;#$NSShiftKeyMask #$NSAlphaShiftKeyMask)))) (unless quote-p (dolist (map hi:*modifier-translations*) (when (logtest useful-modifiers (car map)) (setq bits (logior bits (hi:key-event-modifier-mask (cdr map))))))) (let* ((char (code-char c))) (when (and char (standard-char-p char)) (setq bits (logandc2 bits +shift-event-mask+)))) (hi:make-key-event c bits))))))) ;; For now, this is only used to abort i-search. All actual mouse handling is done ;; by Cocoa. In the future might want to allow users to extend via hemlock, e.g. ;; to implement mouse-copy. ;; Also -- shouldn't this happen on mouse up? (objc:defmethod (#/mouseDown: :void) ((self hemlock-textstorage-text-view) event) ;; If no modifier keys are pressed, send hemlock a no-op. ;; (Or almost a no-op - this does an update-hemlock-selection as a side-effect) (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event)) (let* ((view (hemlock-view self))) (when view (unless (eventqueue-abort-pending-p self) (hi::handle-hemlock-event view #k"leftdown"))))) (call-next-method event)) #+GZ (objc:defmethod (#/mouseUp: :void) ((self hemlock-textstorage-text-view) event) (log-debug "~&MOUSE UP!!") (call-next-method event)) (defmethod assume-not-editing ((tv hemlock-textstorage-text-view)) (assume-not-editing (#/textStorage tv))) (objc:defmethod (#/changeColor: :void) ((self hemlock-textstorage-text-view) sender) (declare (ignorable sender)) #+debug (#_NSLog #@"Change color to = %@" :id (#/color sender))) (def-cocoa-default *layout-text-in-background* :bool t "When true, do text layout when idle.") (objc:defmethod (#/layoutManager:didCompleteLayoutForTextContainer:atEnd: :void) ((self hemlock-textstorage-text-view) layout cont (flag :)) (declare (ignorable cont flag)) #+debug (#_NSLog #@"layout complete: container = %@, atend = %d" :id cont :int (if flag 1 0)) (unless *layout-text-in-background* (#/setDelegate: layout +null-ptr+) (#/setBackgroundLayoutEnabled: layout nil))) ;;; Note changes to the textview's background color; record them ;;; as the value of the "temporary" foreground color (for blinking). (objc:defmethod (#/setBackgroundColor: :void) ((self hemlock-textstorage-text-view) color) #+debug (#_NSLog #@"Set background color: %@" :id color) (let* ((old (text-view-blink-color self))) (unless (%null-ptr-p old) (#/release old))) (setf (text-view-blink-color self) (#/retain color)) (call-next-method color)) ;;; Maybe cause 1 character in the textview to blink (by drawing an empty ;;; character rectangle) in synch with the insertion point. (objc:defmethod (#/drawInsertionPointInRect:color:turnedOn: :void) ((self hemlock-textstorage-text-view) (r :ect) color (flag :)) (unless (or (not (eq ccl::*current-process* ccl::*initial-process*)) (#/editingInProgress (#/textStorage self))) (unless (eql #$NO (text-view-blink-enabled self)) (let* ((layout (#/layoutManager self)) (container (#/textContainer self)) (blink-color (text-view-blink-color self))) ;; We toggle the blinked character "off" by setting its ;; foreground color to the textview's background color. ;; The blinked character should be "off" whenever the insertion ;; point is drawn as "on". (This means that when this method ;; is invoked to tunr off the insertion point - as when a ;; view loses keyboard focus - the matching paren character ;; is drawn. (ns:with-ns-range (char-range (text-view-blink-location self) 1) (let* ((glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange: layout char-range +null-ptr+))) #+debug (#_NSLog #@"Flag = %d, location = %d" : (if flag #$YES #$NO) :int (text-view-blink-location self)) (let* ((rect (#/boundingRectForGlyphRange:inTextContainer: layout glyph-range container))) (#/set blink-color) (#_NSRectFill rect)) (unless flag (#/drawGlyphsForGlyphRange:atPoint: layout glyph-range (#/textContainerOrigin self)))))))) (call-next-method r color flag)) (defmethod disable-blink ((self hemlock-textstorage-text-view)) (when (eql (text-view-blink-enabled self) #$YES) (setf (text-view-blink-enabled self) #$NO) (ns:with-ns-range (char-range (text-view-blink-location self) 1) (let* ((layout (#/layoutManager self)) (glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange: layout char-range +null-ptr+))) (#/lockFocus self) (#/drawGlyphsForGlyphRange:atPoint: layout glyph-range (#/textContainerOrigin self)) (#/unlockFocus self))))) (defmethod update-blink ((self hemlock-textstorage-text-view)) (disable-blink self) (let* ((buffer (hemlock-buffer self))) (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp")) (let* ((hi::*current-buffer* buffer) (point (hi::buffer-point buffer))) #+debug (#_NSLog #@"Syntax check for blinking") (update-buffer-package (hi::buffer-document buffer) buffer) (cond ((eql (hi::next-character point) #\() (hemlock::pre-command-parse-check point) (when (hemlock::valid-spot point t) (hi::with-mark ((temp point)) (when (hemlock::list-offset temp 1) #+debug (#_NSLog #@"enable blink, forward") (setf (text-view-blink-location self) (1- (hi:mark-absolute-position temp)) (text-view-blink-enabled self) #$YES))))) ((eql (hi::previous-character point) #\)) (hemlock::pre-command-parse-check point) (when (hemlock::valid-spot point nil) (hi::with-mark ((temp point)) (when (hemlock::list-offset temp -1) #+debug (#_NSLog #@"enable blink, backward") (setf (text-view-blink-location self) (hi:mark-absolute-position temp) (text-view-blink-enabled self) #$YES)))))))))) ;;; Set and display the selection at pos, whose length is len and whose ;;; affinity is affinity. This should never be called from any Cocoa ;;; event handler; it should not call anything that'll try to set the ;;; underlying buffer's point and/or mark (objc:defmethod (#/updateSelection:length:affinity: :void) ((self hemlock-textstorage-text-view) (pos :int) (length :int) (affinity :electionffinity)) (assume-cocoa-thread) (when (eql length 0) (update-blink self)) (rlet ((range :ns-range :location pos :length length)) (ccl::%call-next-objc-method self hemlock-textstorage-text-view (@selector #/setSelectedRange:affinity:stillSelecting:) '(:void :ange :electionffinity :) range affinity nil) (assume-not-editing self) (when (> length 0) (let* ((ts (#/textStorage self))) (with-slots (selection-set-by-search) ts (when (prog1 (eql #$YES selection-set-by-search) (setq selection-set-by-search #$NO)) (highlight-search-selection self pos length))))) )) (defloadvar *can-use-show-find-indicator-for-range* (#/instancesRespondToSelector: ns:ns-text-view (@selector "showFindIndicatorForRange:"))) ;;; Add transient highlighting to a selection established via a search ;;; primitive, if the OS supports it. (defun highlight-search-selection (tv pos length) (when *can-use-show-find-indicator-for-range* (ns:with-ns-range (r pos length) (objc-message-send tv "showFindIndicatorForRange:" :ange r :void)))) ;;; A specialized NSTextView. The NSTextView is part of the "pane" ;;; object that displays buffers. (defclass hemlock-text-view (hemlock-textstorage-text-view) ((pane :foreign-type :id :accessor text-view-pane) (char-width :foreign-type :loat :accessor text-view-char-width) (line-height :foreign-type :loat :accessor text-view-line-height)) (:metaclass ns:+ns-object)) (declaim (special hemlock-text-view)) (defmethod hemlock-view ((self hemlock-text-view)) (let ((pane (text-view-pane self))) (when pane (hemlock-view pane)))) (objc:defmethod (#/evalSelection: :void) ((self hemlock-text-view) sender) (declare (ignore sender)) (let* ((buffer (hemlock-buffer self)) (package-name (hi::variable-value 'hemlock::current-package :buffer buffer)) (pathname (hi::buffer-pathname buffer)) (ranges (#/selectedRanges self)) (text (#/string self))) (dotimes (i (#/count ranges)) (let* ((r (#/rangeValue (#/objectAtIndex: ranges i))) (s (#/substringWithRange: text r))) (setq s (lisp-string-from-nsstring s)) (ui-object-eval-selection *NSApp* (list package-name pathname s)))))) (objc:defmethod (#/loadBuffer: :void) ((self hemlock-text-view) sender) (declare (ignore sender)) (let* ((buffer (hemlock-buffer self)) (package-name (hi::variable-value 'hemlock::current-package :buffer buffer)) (pathname (hi::buffer-pathname buffer))) (ui-object-load-buffer *NSApp* (list package-name pathname)))) (objc:defmethod (#/compileBuffer: :void) ((self hemlock-text-view) sender) (declare (ignore sender)) (let* ((buffer (hemlock-buffer self)) (package-name (hi::variable-value 'hemlock::current-package :buffer buffer)) (pathname (hi::buffer-pathname buffer))) (ui-object-compile-buffer *NSApp* (list package-name pathname)))) (objc:defmethod (#/compileAndLoadBuffer: :void) ((self hemlock-text-view) sender) (declare (ignore sender)) (let* ((buffer (hemlock-buffer self)) (package-name (hi::variable-value 'hemlock::current-package :buffer buffer)) (pathname (hi::buffer-pathname buffer))) (ui-object-compile-and-load-buffer *NSApp* (list package-name pathname)))) (defloadvar *text-view-context-menu* ()) (defun text-view-context-menu () (or *text-view-context-menu* (setq *text-view-context-menu* (#/retain (let* ((menu (make-instance 'ns:ns-menu :with-title #@"Menu"))) (#/addItemWithTitle:action:keyEquivalent: menu #@"Cut" (@selector #/cut:) #@"") (#/addItemWithTitle:action:keyEquivalent: menu #@"Copy" (@selector #/copy:) #@"") (#/addItemWithTitle:action:keyEquivalent: menu #@"Paste" (@selector #/paste:) #@"") ;; Separator (#/addItem: menu (#/separatorItem ns:ns-menu-item)) (#/addItemWithTitle:action:keyEquivalent: menu #@"Background Color ..." (@selector #/changeBackgroundColor:) #@"") (#/addItemWithTitle:action:keyEquivalent: menu #@"Text Color ..." (@selector #/changeTextColor:) #@"") menu))))) (objc:defmethod (#/changeBackgroundColor: :void) ((self hemlock-text-view) sender) (let* ((colorpanel (#/sharedColorPanel ns:ns-color-panel)) (color (#/backgroundColor self))) (#/close colorpanel) (#/setAction: colorpanel (@selector #/updateBackgroundColor:)) (#/setColor: colorpanel color) (#/setTarget: colorpanel self) (#/setContinuous: colorpanel nil) (#/orderFrontColorPanel: *NSApp* sender))) (objc:defmethod (#/updateBackgroundColor: :void) ((self hemlock-text-view) sender) (when (#/isVisible sender) (let* ((color (#/color sender))) (unless (typep self 'echo-area-view) (let* ((window (#/window self)) (echo-view (unless (%null-ptr-p window) (slot-value window 'echo-area-view)))) (when echo-view (#/setBackgroundColor: echo-view color)))) #+debug (#_NSLog #@"Updating backgroundColor to %@, sender = %@" :id color :id sender) (#/setBackgroundColor: self color)))) (objc:defmethod (#/changeTextColor: :void) ((self hemlock-text-view) sender) (let* ((colorpanel (#/sharedColorPanel ns:ns-color-panel)) (textstorage (#/textStorage self)) (color (#/objectForKey: (#/objectAtIndex: (slot-value textstorage 'styles) 0) #&NSForegroundColorAttributeName))) (#/close colorpanel) (#/setAction: colorpanel (@selector #/updateTextColor:)) (#/setColor: colorpanel color) (#/setTarget: colorpanel self) (#/setContinuous: colorpanel nil) (#/orderFrontColorPanel: *NSApp* sender))) (objc:defmethod (#/updateTextColor: :void) ((self hemlock-textstorage-text-view) sender) (unwind-protect (progn (#/setUsesFontPanel: self t) (ccl::%call-next-objc-method self hemlock-textstorage-text-view (@selector #/changeColor:) '(:void :id) sender)) (#/setUsesFontPanel: self nil)) (#/setNeedsDisplay: self t)) (objc:defmethod (#/updateTextColor: :void) ((self hemlock-text-view) sender) (let* ((textstorage (#/textStorage self)) (styles (slot-value textstorage 'styles)) (newcolor (#/color sender))) (dotimes (i 4) (let* ((dict (#/objectAtIndex: styles i))) (#/setValue:forKey: dict newcolor #&NSForegroundColorAttributeName))) (call-next-method sender))) (defmethod text-view-string-cache ((self hemlock-textstorage-text-view)) (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self)))) (objc:defmethod (#/selectionRangeForProposedRange:granularity: :ns-range) ((self hemlock-textstorage-text-view) (proposed :ns-range) (g :electionranularity)) #+debug (#_NSLog #@"Granularity = %d" :int g) (objc:returning-foreign-struct (r) (block HANDLED (let* ((index (ns:ns-range-location proposed)) (length (ns:ns-range-length proposed))) (when (and (eql 0 length) ; not extending existing selection (not (eql g #$NSSelectByCharacter))) (let* ((textstorage (#/textStorage self)) (cache (hemlock-buffer-string-cache (#/hemlockString textstorage))) (buffer (if cache (buffer-cache-buffer cache)))) (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp")) (let* ((hi::*current-buffer* buffer)) (hi::with-mark ((m1 (hi::buffer-point buffer))) (move-hemlock-mark-to-absolute-position m1 cache index) (hemlock::pre-command-parse-check m1) (when (hemlock::valid-spot m1 nil) (cond ((eql (hi::next-character m1) #\() (hi::with-mark ((m2 m1)) (when (hemlock::list-offset m2 1) (ns:init-ns-range r index (- (hi:mark-absolute-position m2) index)) (return-from HANDLED r)))) ((eql (hi::previous-character m1) #\)) (hi::with-mark ((m2 m1)) (when (hemlock::list-offset m2 -1) (ns:init-ns-range r (hi:mark-absolute-position m2) (- index (hi:mark-absolute-position m2))) (return-from HANDLED r)))))))))))) (call-next-method proposed g) #+debug (#_NSLog #@"range = %@, proposed = %@, granularity = %d" :address (#_NSStringFromRange r) :address (#_NSStringFromRange proposed) :electionranularity g)))) (defun append-output (view string) (assume-cocoa-thread) ;; Arrange to do the append in command context (when view (hi::handle-hemlock-event view #'(lambda () (hemlock::append-buffer-output (hi::hemlock-view-buffer view) string))))) ;;; Update the underlying buffer's point (and "active region", if appropriate. ;;; This is called in response to a mouse click or other event; it shouldn't ;;; be called from the Hemlock side of things. (objc:defmethod (#/setSelectedRange:affinity:stillSelecting: :void) ((self hemlock-text-view) (r :ange) (affinity :electionffinity) (still-selecting :)) #+debug (#_NSLog #@"Set selected range called: location = %d, length = %d, affinity = %d, still-selecting = %d" :int (pref r :ange.location) :int (pref r :ange.length) :electionffinity affinity : (if still-selecting #$YES #$NO)) #+debug (#_NSLog #@"text view string = %@, textstorage string = %@" :id (#/string self) :id (#/string (#/textStorage self))) (unless (#/editingInProgress (#/textStorage self)) (let* ((d (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self)))) (buffer (buffer-cache-buffer d)) (hi::*current-buffer* buffer) (point (hi::buffer-point buffer)) (location (pref r :ange.location)) (len (pref r :ange.length))) (cond ((eql len 0) #+debug (#_NSLog #@"Moving point to absolute position %d" :int location) (setf (hi::buffer-region-active buffer) nil) (move-hemlock-mark-to-absolute-position point d location) (update-blink self)) (t ;; We don't get much information about which end of the ;; selection the mark's at and which end point is at, so ;; we have to sort of guess. In every case I've ever seen, ;; selection via the mouse generates a sequence of calls to ;; this method whose parameters look like: ;; a: range: {n0,0} still-selecting: false [ rarely repeats ] ;; b: range: {n0,0) still-selecting: true [ rarely repeats ] ;; c: range: {n1,m} still-selecting: true [ often repeats ] ;; d: range: {n1,m} still-selecting: false [ rarely repeats ] ;; ;; (Sadly, "affinity" doesn't tell us anything interesting.) ;; We've handled a and b in the clause above; after handling ;; b, point references buffer position n0 and the ;; region is inactive. ;; Let's ignore c, and wait until the selection's stabilized. ;; Make a new mark, a copy of point (position n0). ;; At step d (here), we should have either ;; d1) n1=n0. Mark stays at n0, point moves to n0+m. ;; d2) n1+m=n0. Mark stays at n0, point moves to n0-m. ;; If neither d1 nor d2 apply, arbitrarily assume forward ;; selection: mark at n1, point at n1+m. ;; In all cases, activate Hemlock selection. (unless still-selecting (let* ((pointpos (hi:mark-absolute-position point)) (selection-end (+ location len)) (mark (hi::copy-mark point :right-inserting))) (cond ((eql pointpos location) (move-hemlock-mark-to-absolute-position point d selection-end)) ((eql pointpos selection-end) (move-hemlock-mark-to-absolute-position point d location)) (t (move-hemlock-mark-to-absolute-position mark d location) (move-hemlock-mark-to-absolute-position point d selection-end))) (hemlock::%buffer-push-buffer-mark buffer mark t))))))) (call-next-method r affinity still-selecting)) ;;; Modeline-view ;;; The modeline view is embedded in the horizontal scroll bar of the ;;; scrollview which surrounds the textview in a pane. (A view embedded ;;; in a scrollbar like this is sometimes called a "placard"). Whenever ;;; the view's invalidated, its drawRect: method draws a string containing ;;; the current values of the buffer's modeline fields. (defparameter *modeline-grays* #(255 255 253 247 242 236 231 224 229 234 239 245 252 255)) (defparameter *modeline-height* 14) (defloadvar *modeline-pattern-image* nil) (defun create-modeline-pattern-image () (let* ((n (length *modeline-grays*))) (multiple-value-bind (samples-array samples-macptr) (make-heap-ivector n '(unsigned-byte 8)) (dotimes (i n) (setf (aref samples-array i) (aref *modeline-grays* i))) (rlet ((p :address samples-macptr)) (let* ((rep (make-instance 'ns:ns-bitmap-image-rep :with-bitmap-data-planes p :pixels-wide 1 :pixels-high n :bits-per-sample 8 :samples-per-pixel 1 :has-alpha #$NO :is-planar #$NO :color-space-name #&NSDeviceWhiteColorSpace :bytes-per-row 1 :bits-per-pixel 8)) (image (make-instance 'ns:ns-image :with-size (ns:make-ns-size 1 n)))) (#/addRepresentation: image rep) (#/release rep) (setf *modeline-pattern-image* image)))))) (defclass modeline-view (ns:ns-view) ((pane :foreign-type :id :accessor modeline-view-pane) (text-attributes :foreign-type :id :accessor modeline-text-attributes)) (:metaclass ns:+ns-object)) (objc:defmethod #/initWithFrame: ((self modeline-view) (frame :ect)) (call-next-method frame) (unless *modeline-pattern-image* (create-modeline-pattern-image)) (let* ((size (#/smallSystemFontSize ns:ns-font)) (font (#/systemFontOfSize: ns:ns-font size)) (dict (#/dictionaryWithObject:forKey: ns:ns-dictionary font #&NSFontAttributeName))) (setf (modeline-text-attributes self) (#/retain dict))) self) ;;; Find the underlying buffer. (defun buffer-for-modeline-view (mv) (let* ((pane (modeline-view-pane mv))) (unless (%null-ptr-p pane) (let* ((tv (text-pane-text-view pane))) (unless (%null-ptr-p tv) (hemlock-buffer tv)))))) ;;; Draw a string in the modeline view. The font and other attributes ;;; are initialized lazily; apparently, calling the Font Manager too ;;; early in the loading sequence confuses some Carbon libraries that're ;;; used in the event dispatch mechanism, (defun draw-modeline-string (the-modeline-view) (with-slots (text-attributes) the-modeline-view (let* ((buffer (buffer-for-modeline-view the-modeline-view))) (when buffer (let* ((string (apply #'concatenate 'string (mapcar #'(lambda (field) (funcall (hi::modeline-field-function field) buffer)) (hi::buffer-modeline-fields buffer))))) (#/drawAtPoint:withAttributes: (%make-nsstring string) (ns:make-ns-point 5 1) text-attributes)))))) ;;; Draw the underlying buffer's modeline string on a white background ;;; with a bezeled border around it. (objc:defmethod (#/drawRect: :void) ((self modeline-view) (rect :ect)) (declare (ignorable rect)) (let* ((bounds (#/bounds self)) (context (#/currentContext ns:ns-graphics-context))) (#/saveGraphicsState context) (ns:with-ns-point (p0 0 (ns:ns-rect-height bounds)) (let ((p1 (#/convertPoint:toView: self p0 +null-ptr+))) (#/setPatternPhase: context p1))) (#/set (#/colorWithPatternImage: ns:ns-color *modeline-pattern-image*)) (#_NSRectFill bounds) (#/set (#/colorWithCalibratedWhite:alpha: ns:ns-color 0.3333 1.0)) (ns:with-ns-rect (r 0 0.5 (ns:ns-rect-width bounds) 0.5) (#_NSRectFill r)) (ns:with-ns-rect (r 0 (- (ns:ns-rect-height bounds) 0.5) (ns:ns-rect-width bounds) (- (ns:ns-rect-height bounds) 0.5)) (#_NSRectFill r)) (#/set (#/blackColor ns:ns-color)) (draw-modeline-string self) (#/restoreGraphicsState context))) ;;; Hook things up so that the modeline is updated whenever certain buffer ;;; attributes change. (hi::%init-mode-redisplay) ;;; Modeline-scroll-view ;;; This is just an NSScrollView that draws a "placard" view (the modeline) ;;; in the horizontal scrollbar. The modeline's arbitrarily given the ;;; leftmost 75% of the available real estate. (defclass modeline-scroll-view (ns:ns-scroll-view) ((modeline :foreign-type :id :accessor scroll-view-modeline) (pane :foreign-type :id :accessor scroll-view-pane)) (:metaclass ns:+ns-object)) ;;; Making an instance of a modeline scroll view instantiates the ;;; modeline view, as well. (objc:defmethod #/initWithFrame: ((self modeline-scroll-view) (frame :ect)) (let* ((v (call-next-method frame))) (when v (let* ((modeline (make-instance 'modeline-view))) (#/addSubview: v modeline) (setf (scroll-view-modeline v) modeline))) v)) ;;; Scroll views use the "tile" method to lay out their subviews. ;;; After the next-method has done so, steal some room in the horizontal ;;; scroll bar and place the modeline view there. (objc:defmethod (#/tile :void) ((self modeline-scroll-view)) (call-next-method) (let* ((modeline (scroll-view-modeline self))) (when (and (#/hasHorizontalScroller self) (not (%null-ptr-p modeline))) (let* ((hscroll (#/horizontalScroller self)) (scrollbar-frame (#/frame hscroll)) (modeline-frame (#/frame hscroll)) ; sic (modeline-width (* (pref modeline-frame :ect.size.width) 0.75f0))) (declare (type cgfloat modeline-width)) (setf (pref modeline-frame :ect.size.width) modeline-width (the cgfloat (pref scrollbar-frame :ect.size.width)) (- (the cgfloat (pref scrollbar-frame :ect.size.width)) modeline-width) (the cg-float (pref scrollbar-frame :ect.origin.x)) (+ (the cgfloat (pref scrollbar-frame :ect.origin.x)) modeline-width)) (#/setFrame: hscroll scrollbar-frame) (#/setFrame: modeline modeline-frame))))) ;;; Text-pane ;;; The text pane is just an NSBox that (a) provides a draggable border ;;; around (b) encapsulates the text view and the mode line. (defclass text-pane (ns:ns-box) ((hemlock-view :initform nil :reader text-pane-hemlock-view) (text-view :foreign-type :id :accessor text-pane-text-view) (mode-line :foreign-type :id :accessor text-pane-mode-line) (scroll-view :foreign-type :id :accessor text-pane-scroll-view)) (:metaclass ns:+ns-object)) (defmethod hemlock-view ((self text-pane)) (text-pane-hemlock-view self)) ;;; Mark the buffer's modeline as needing display. This is called whenever ;;; "interesting" attributes of a buffer are changed. (defun hemlock-ext:invalidate-modeline (buffer) (let* ((doc (hi::buffer-document buffer))) (when doc (document-invalidate-modeline doc)))) (def-cocoa-default *text-pane-margin-width* :float 0.0f0 "width of indented margin around text pane") (def-cocoa-default *text-pane-margin-height* :float 0.0f0 "height of indented margin around text pane") (objc:defmethod #/initWithFrame: ((self text-pane) (frame :ect)) (let* ((pane (call-next-method frame))) (unless (%null-ptr-p pane) (#/setAutoresizingMask: pane (logior #$NSViewWidthSizable #$NSViewHeightSizable)) (#/setBoxType: pane #$NSBoxPrimary) (#/setBorderType: pane #$NSNoBorder) (#/setContentViewMargins: pane (ns:make-ns-size *text-pane-margin-width* *text-pane-margin-height*)) (#/setTitlePosition: pane #$NSNoTitle)) pane)) (objc:defmethod #/defaultMenu ((class +hemlock-text-view)) (text-view-context-menu)) ;;; If we don't override this, NSTextView will start adding Google/ ;;; Spotlight search options and dictionary lookup when a selection ;;; is active. (objc:defmethod #/menuForEvent: ((self hemlock-text-view) event) (declare (ignore event)) (#/menu self)) (defun make-scrolling-text-view-for-textstorage (textstorage x y width height tracks-width color style) (let* ((scrollview (#/autorelease (make-instance 'modeline-scroll-view :with-frame (ns:make-ns-rect x y width height))))) (#/setBorderType: scrollview #$NSNoBorder) (#/setHasVerticalScroller: scrollview t) (#/setHasHorizontalScroller: scrollview t) (#/setRulersVisible: scrollview nil) (#/setAutoresizingMask: scrollview (logior #$NSViewWidthSizable #$NSViewHeightSizable)) (#/setAutoresizesSubviews: (#/contentView scrollview) t) (let* ((layout (make-instance 'ns:ns-layout-manager))) #+suffer (#/setTypesetter: layout (make-instance 'hemlock-ats-typesetter)) (#/addLayoutManager: textstorage layout) (#/setUsesScreenFonts: layout *use-screen-fonts*) (#/release layout) (let* ((contentsize (#/contentSize scrollview))) (ns:with-ns-size (containersize large-number-for-text large-number-for-text) (ns:with-ns-rect (tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize)) (ns:init-ns-size containersize large-number-for-text large-number-for-text) (ns:init-ns-rect tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize)) (let* ((container (#/autorelease (make-instance 'ns:ns-text-container :with-container-size containersize)))) (#/addTextContainer: layout container) (let* ((tv (#/autorelease (make-instance 'hemlock-text-view :with-frame tv-frame :text-container container)))) (#/setDelegate: layout tv) (#/setMinSize: tv (ns:make-ns-size 0 (ns:ns-size-height contentsize))) (#/setMaxSize: tv (ns:make-ns-size large-number-for-text large-number-for-text)) (#/setRichText: tv nil) (#/setAutoresizingMask: tv #$NSViewWidthSizable) (#/setBackgroundColor: tv color) (#/setTypingAttributes: tv (#/objectAtIndex: (#/styles textstorage) style)) (#/setSmartInsertDeleteEnabled: tv nil) (#/setAllowsUndo: tv nil) ; don't want NSTextView undo (#/setUsesFindPanel: tv t) (#/setUsesFontPanel: tv nil) (#/setMenu: tv (text-view-context-menu)) ;; The container tracking and the text view sizability along a ;; particular axis must always be different, or else things can ;; get really confused (possibly causing an infinite loop). (if (or tracks-width *wrap-lines-to-window*) (progn (#/setWidthTracksTextView: container t) (#/setHeightTracksTextView: container nil) (#/setHorizontallyResizable: tv nil) (#/setVerticallyResizable: tv t)) (progn (#/setWidthTracksTextView: container nil) (#/setHeightTracksTextView: container nil) (#/setHorizontallyResizable: tv t) (#/setVerticallyResizable: tv t))) (#/setDocumentView: scrollview tv) (values tv scrollview))))))))) (defun make-scrolling-textview-for-pane (pane textstorage track-width color style) (let* ((contentrect (#/frame (#/contentView pane)))) (multiple-value-bind (tv scrollview) (make-scrolling-text-view-for-textstorage textstorage (ns:ns-rect-x contentrect) (ns:ns-rect-y contentrect) (ns:ns-rect-width contentrect) (ns:ns-rect-height contentrect) track-width color style) (#/setContentView: pane scrollview) (setf (slot-value pane 'scroll-view) scrollview (slot-value pane 'text-view) tv (slot-value tv 'pane) pane (slot-value scrollview 'pane) pane) (let* ((modeline (scroll-view-modeline scrollview))) (setf (slot-value pane 'mode-line) modeline (slot-value modeline 'pane) pane)) tv))) (defmethod hemlock-ext:change-active-pane ((view hi:hemlock-view) new-pane) #+GZ (log-debug "change active pane to ~s" new-pane) (let* ((pane (hi::hemlock-view-pane view)) (text-view (text-pane-text-view pane)) (tv (ecase new-pane (:echo (slot-value text-view 'peer)) (:text text-view)))) (activate-hemlock-view tv))) (defclass echo-area-view (hemlock-textstorage-text-view) () (:metaclass ns:+ns-object)) (declaim (special echo-area-view)) (defmethod hemlock-view ((self echo-area-view)) (let ((text-view (slot-value self 'peer))) (when text-view (hemlock-view text-view)))) ;;; The "document" for an echo-area isn't a real NSDocument. (defclass echo-area-document (ns:ns-object) ((textstorage :foreign-type :id)) (:metaclass ns:+ns-object)) (defmethod hemlock-buffer ((self echo-area-document)) (let ((ts (slot-value self 'textstorage))) (unless (%null-ptr-p ts) (hemlock-buffer ts)))) (objc:defmethod #/undoManager ((self echo-area-document)) +null-ptr+) ;For now, undo is not supported for echo-areas (defmethod update-buffer-package ((doc echo-area-document) buffer) (declare (ignore buffer))) (defmethod document-invalidate-modeline ((self echo-area-document)) nil) (objc:defmethod (#/close :void) ((self echo-area-document)) (let* ((ts (slot-value self 'textstorage))) (unless (%null-ptr-p ts) (setf (slot-value self 'textstorage) (%null-ptr)) (close-hemlock-textstorage ts)))) (objc:defmethod (#/updateChangeCount: :void) ((self echo-area-document) (change :ocumenthangeype)) (declare (ignore change))) (defun make-echo-area (the-hemlock-frame x y width height main-buffer color) (let* ((box (make-instance 'ns:ns-view :with-frame (ns:make-ns-rect x y width height)))) (#/setAutoresizingMask: box #$NSViewWidthSizable) (let* ((box-frame (#/bounds box)) (containersize (ns:make-ns-size large-number-for-text (ns:ns-rect-height box-frame))) (clipview (make-instance 'ns:ns-clip-view :with-frame box-frame))) (#/setAutoresizingMask: clipview (logior #$NSViewWidthSizable #$NSViewHeightSizable)) (#/setBackgroundColor: clipview color) (#/addSubview: box clipview) (#/setAutoresizesSubviews: box t) (#/release clipview) (let* ((buffer (hi::make-echo-buffer)) (textstorage (progn ;; What's the reason for sharing this? Is it just the lock? (setf (hi::buffer-gap-context buffer) (hi::ensure-buffer-gap-context main-buffer)) (make-textstorage-for-hemlock-buffer buffer))) (doc (make-instance 'echo-area-document)) (layout (make-instance 'ns:ns-layout-manager)) (container (#/autorelease (make-instance 'ns:ns-text-container :with-container-size containersize)))) (#/addLayoutManager: textstorage layout) (#/setUsesScreenFonts: layout *use-screen-fonts*) (#/addTextContainer: layout container) (#/release layout) (let* ((echo (make-instance 'echo-area-view :with-frame box-frame :text-container container))) (#/setMinSize: echo (pref box-frame :ect.size)) (#/setMaxSize: echo (ns:make-ns-size large-number-for-text large-number-for-text)) (#/setRichText: echo nil) (#/setUsesFontPanel: echo nil) (#/setHorizontallyResizable: echo t) (#/setVerticallyResizable: echo nil) (#/setAutoresizingMask: echo #$NSViewNotSizable) (#/setBackgroundColor: echo color) (#/setWidthTracksTextView: container nil) (#/setHeightTracksTextView: container nil) (#/setMenu: echo +null-ptr+) (setf (hemlock-frame-echo-area-buffer the-hemlock-frame) buffer (slot-value doc 'textstorage) textstorage (hi::buffer-document buffer) doc) (#/setDocumentView: clipview echo) (#/setAutoresizesSubviews: clipview nil) (#/sizeToFit echo) (values echo box)))))) (defun make-echo-area-for-window (w main-buffer color) (let* ((content-view (#/contentView w)) (bounds (#/bounds content-view))) (multiple-value-bind (echo-area box) (make-echo-area w 0.0f0 0.0f0 (- (ns:ns-rect-width bounds) 16.0f0) 20.0f0 main-buffer color) (#/addSubview: content-view box) echo-area))) (defclass hemlock-frame (ns:ns-window) ((echo-area-view :foreign-type :id) (pane :foreign-type :id) (echo-area-buffer :initform nil :accessor hemlock-frame-echo-area-buffer) (echo-area-stream :initform nil :accessor hemlock-frame-echo-area-stream)) (:metaclass ns:+ns-object)) (declaim (special hemlock-frame)) (defmethod hemlock-view ((self hemlock-frame)) (let ((pane (slot-value self 'pane))) (unless (%null-ptr-p pane) (hemlock-view pane)))) (objc:defmethod (#/runErrorSheet: :void) ((self hemlock-frame) message) #+debug (#_NSLog #@"runErrorSheet: signal = %@" :id signal) (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title (if (logbitp 0 (random 2)) #@"Not OK, but what can you do?" #@"The sky is falling. FRED never did this!") +null-ptr+ +null-ptr+ self self +null-ptr+ +null-ptr+ +null-ptr+ message)) (defun report-condition-in-hemlock-frame (condition frame) (assume-cocoa-thread) (let ((message (nsstring-for-lisp-condition condition))) (#/performSelectorOnMainThread:withObject:waitUntilDone: frame (@selector #/runErrorSheet:) message t))) (defmethod hemlock-ext:report-hemlock-error ((view hi:hemlock-view) condition debug-p) (when debug-p (maybe-log-callback-error condition)) (let ((pane (hi::hemlock-view-pane view))) (when (and pane (not (%null-ptr-p pane))) (report-condition-in-hemlock-frame condition (#/window pane))))) (objc:defmethod (#/close :void) ((self hemlock-frame)) (let* ((content-view (#/contentView self)) (subviews (#/subviews content-view))) (do* ((i (1- (#/count subviews)) (1- i))) ((< i 0)) (#/removeFromSuperviewWithoutNeedingDisplay (#/objectAtIndex: subviews i)))) (let* ((buf (hemlock-frame-echo-area-buffer self)) (echo-doc (if buf (hi::buffer-document buf)))) (when echo-doc (setf (hemlock-frame-echo-area-buffer self) nil) (#/close echo-doc))) (release-canonical-nsobject self) (call-next-method)) (defun new-hemlock-document-window (class) (let* ((w (new-cocoa-window :class class :activate nil))) (values w (add-pane-to-window w :reserve-below 20.0)))) (defun add-pane-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0)) (let* ((window-content-view (#/contentView w)) (window-frame (#/frame window-content-view))) (ns:with-ns-rect (pane-rect 0 reserve-below (ns:ns-rect-width window-frame) (- (ns:ns-rect-height window-frame) (+ reserve-above reserve-below))) (let* ((pane (make-instance 'text-pane :with-frame pane-rect))) (#/addSubview: window-content-view pane) pane)))) (defun textpane-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style) (let* ((pane (nth-value 1 (new-hemlock-document-window class)))) (make-scrolling-textview-for-pane pane ts container-tracks-text-view-width color style) (multiple-value-bind (height width) (size-of-char-in-font (default-font)) (size-text-pane pane height width nrows ncols)) pane)) (defun hemlock-buffer-from-nsstring (nsstring name &rest modes) (let* ((buffer (make-hemlock-buffer name :modes modes))) (nsstring-to-buffer nsstring buffer))) (defun %nsstring-to-hemlock-string (nsstring) "returns line-termination of string" (let* ((string (lisp-string-from-nsstring nsstring)) (lfpos (position #\linefeed string)) (crpos (position #\return string)) (line-termination (if crpos (if (eql lfpos (1+ crpos)) :crlf :cr) :lf)) (hemlock-string (case line-termination (:crlf (remove #\return string)) (:cr (nsubstitute #\linefeed #\return string)) (t string)))) (values hemlock-string line-termination))) ;: TODO: I think this is jumping through hoops because it want to be invokable outside the main ;; cocoa thread. (defun nsstring-to-buffer (nsstring buffer) (let* ((document (hi::buffer-document buffer)) (hi::*current-buffer* buffer) (region (hi::buffer-region buffer))) (multiple-value-bind (hemlock-string line-termination) (%nsstring-to-hemlock-string nsstring) (setf (hi::buffer-line-termination buffer) line-termination) (setf (hi::buffer-document buffer) nil) ;; What's this about?? (unwind-protect (let ((point (hi::buffer-point buffer))) (hi::delete-region region) (hi::insert-string point hemlock-string) (setf (hi::buffer-modified buffer) nil) (hi::buffer-start point) ;; TODO: why would this be needed? insert-string should take care of any internal bookkeeping. (hi::renumber-region region) buffer) (setf (hi::buffer-document buffer) document))))) (setq hi::*beep-function* #'(lambda (stream) (declare (ignore stream)) (#_NSBeep))) ;;; This function must run in the main event thread. (defun %hemlock-frame-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style) (assume-cocoa-thread) (let* ((pane (textpane-for-textstorage class ts ncols nrows container-tracks-text-view-width color style)) (buffer (hemlock-buffer ts)) (frame (#/window pane)) (echo-area (make-echo-area-for-window frame buffer color)) (echo-buffer (hemlock-buffer (#/textStorage echo-area))) (tv (text-pane-text-view pane))) #+GZ (assert echo-buffer) (with-slots (peer) tv (setq peer echo-area)) (with-slots (peer) echo-area (setq peer tv)) (setf (slot-value frame 'echo-area-view) echo-area (slot-value frame 'pane) pane) (setf (slot-value pane 'hemlock-view) (make-instance 'hi:hemlock-view :buffer buffer :pane pane :echo-area-buffer echo-buffer)) (activate-hemlock-view tv) frame)) (defun hi::lock-buffer (b) (grab-lock (hi::buffer-lock b))) (defun hi::unlock-buffer (b) (release-lock (hi::buffer-lock b))) (defun hemlock-ext:invoke-modifying-buffer-storage (buffer thunk) (assume-cocoa-thread) (when buffer ;; nil means just get rid of any prior buffer (setq buffer (require-type buffer 'hi::buffer))) (let ((old *buffer-being-edited*)) (if (eq buffer old) (funcall thunk) (unwind-protect (progn (buffer-document-end-editing old) (buffer-document-begin-editing buffer) (funcall thunk)) (buffer-document-end-editing buffer) (buffer-document-begin-editing old))))) (defun buffer-document-end-editing (buffer) (when buffer (let* ((document (hi::buffer-document (require-type buffer 'hi::buffer)))) (when document (setq *buffer-being-edited* nil) (let ((ts (slot-value document 'textstorage))) (#/endEditing ts) (update-hemlock-selection ts)))))) (defun buffer-document-begin-editing (buffer) (when buffer (let* ((document (hi::buffer-document buffer))) (when document (setq *buffer-being-edited* buffer) (#/beginEditing (slot-value document 'textstorage)))))) (defun document-edit-level (document) (assume-cocoa-thread) ;; see comment in #/editingInProgress (slot-value (slot-value document 'textstorage) 'edit-count)) (defun perform-edit-change-notification (textstorage selector pos n &optional (extra 0)) (with-lock-grabbed (*buffer-change-invocation-lock*) (let* ((invocation *buffer-change-invocation*)) (rlet ((ppos :nteger pos) (pn :nteger n) (pextra :nteger extra)) (#/setTarget: invocation textstorage) (#/setSelector: invocation selector) (#/setArgument:atIndex: invocation ppos 2) (#/setArgument:atIndex: invocation pn 3) (#/setArgument:atIndex: invocation pextra 4)) (#/performSelectorOnMainThread:withObject:waitUntilDone: invocation (@selector #/invoke) +null-ptr+ t)))) (defun textstorage-note-insertion-at-position (textstorage pos n) #+debug (#_NSLog #@"insertion at position %d, len %d" :int pos :int n) (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedAttributes (ns:make-ns-range pos 0) n) (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range pos n) 0)) (defun hi::buffer-note-font-change (buffer region font) (when (hi::bufferp buffer) (let* ((document (hi::buffer-document buffer)) (textstorage (if document (slot-value document 'textstorage))) (pos (hi:mark-absolute-position (hi::region-start region))) (n (- (hi:mark-absolute-position (hi::region-end region)) pos))) (perform-edit-change-notification textstorage (@selector #/noteHemlockAttrChangeAtPosition:length:) pos n font)))) (defun buffer-active-font-attributes (buffer) (let* ((style 0) (region (hi::buffer-active-font-region buffer)) (textstorage (slot-value (hi::buffer-document buffer) 'textstorage)) (styles (#/styles textstorage))) (when region (let* ((start (hi::region-end region))) (setq style (hi::font-mark-font start)))) (#/objectAtIndex: styles style))) ;; Note that inserted a string of length n at mark. Assumes this is called after ;; buffer marks were updated. (defun hi::buffer-note-insertion (buffer mark n) (when (hi::bufferp buffer) (let* ((document (hi::buffer-document buffer)) (textstorage (if document (slot-value document 'textstorage)))) (when textstorage (let* ((pos (hi:mark-absolute-position mark))) (when (eq (hi::mark-%kind mark) :left-inserting) ;; Make up for the fact that the mark moved forward with the insertion. ;; For :right-inserting and :temporary marks, they should be left back. (decf pos n)) (perform-edit-change-notification textstorage (@selector #/noteHemlockInsertionAtPosition:length:) pos n)))))) (defun hi::buffer-note-modification (buffer mark n) (when (hi::bufferp buffer) (let* ((document (hi::buffer-document buffer)) (textstorage (if document (slot-value document 'textstorage)))) (when textstorage (perform-edit-change-notification textstorage (@selector #/noteHemlockModificationAtPosition:length:) (hi:mark-absolute-position mark) n))))) (defun hi::buffer-note-deletion (buffer mark n) (when (hi::bufferp buffer) (let* ((document (hi::buffer-document buffer)) (textstorage (if document (slot-value document 'textstorage)))) (when textstorage (let* ((pos (hi:mark-absolute-position mark))) (perform-edit-change-notification textstorage (@selector #/noteHemlockDeletionAtPosition:length:) pos (abs n))))))) (defun hemlock-ext:note-buffer-saved (buffer) (assume-cocoa-thread) (let* ((document (hi::buffer-document buffer))) (when document ;; Hmm... I guess this is always done by the act of saving. nil))) (defun hemlock-ext:note-buffer-unsaved (buffer) (assume-cocoa-thread) (let* ((document (hi::buffer-document buffer))) (when document (#/updateChangeCount: document #$NSChangeCleared)))) (defun size-of-char-in-font (f) (let* ((sf (#/screenFont f)) (screen-p *use-screen-fonts*)) (if (%null-ptr-p sf) (setq sf f screen-p nil)) (let* ((layout (#/autorelease (#/init (#/alloc ns:ns-layout-manager))))) (#/setUsesScreenFonts: layout screen-p) (values (fround (#/defaultLineHeightForFont: layout sf)) (fround (ns:ns-size-width (#/advancementForGlyph: sf (#/glyphWithName: sf #@" ")))))))) (defun size-text-pane (pane line-height char-width nrows ncols) (let* ((tv (text-pane-text-view pane)) (height (fceiling (* nrows line-height))) (width (fceiling (* ncols char-width))) (scrollview (text-pane-scroll-view pane)) (window (#/window scrollview)) (has-horizontal-scroller (#/hasHorizontalScroller scrollview)) (has-vertical-scroller (#/hasVerticalScroller scrollview))) (ns:with-ns-size (tv-size (+ width (* 2 (#/lineFragmentPadding (#/textContainer tv)))) height) (when has-vertical-scroller (#/setVerticalLineScroll: scrollview line-height) (#/setVerticalPageScroll: scrollview (cgfloat 0.0) #|line-height|#)) (when has-horizontal-scroller (#/setHorizontalLineScroll: scrollview char-width) (#/setHorizontalPageScroll: scrollview (cgfloat 0.0) #|char-width|#)) (let* ((sv-size (#/frameSizeForContentSize:hasHorizontalScroller:hasVerticalScroller:borderType: ns:ns-scroll-view tv-size has-horizontal-scroller has-vertical-scroller (#/borderType scrollview))) (pane-frame (#/frame pane)) (margins (#/contentViewMargins pane))) (incf (ns:ns-size-height sv-size) (+ (ns:ns-rect-y pane-frame) (* 2 (ns:ns-size-height margins)))) (incf (ns:ns-size-width sv-size) (ns:ns-size-width margins)) (#/setContentSize: window sv-size) (setf (slot-value tv 'char-width) char-width (slot-value tv 'line-height) line-height) (#/setResizeIncrements: window (ns:make-ns-size char-width line-height)))))) (defclass hemlock-editor-window-controller (ns:ns-window-controller) () (:metaclass ns:+ns-object)) (defmethod hemlock-view ((self hemlock-editor-window-controller)) (let ((frame (#/window self))) (unless (%null-ptr-p frame) (hemlock-view frame)))) ;;; Map *default-file-character-encoding* to an :tringncoding (defun get-default-encoding () (let* ((string (string (or *default-file-character-encoding* "ISO-8859-1"))) (len (length string))) (with-cstrs ((cstr string)) (with-nsstr (nsstr cstr len) (let* ((cf (#_CFStringConvertIANACharSetNameToEncoding nsstr))) (if (= cf #$kCFStringEncodingInvalidId) (setq cf (#_CFStringGetSystemEncoding))) (let* ((ns (#_CFStringConvertEncodingToNSStringEncoding cf))) (if (= ns #$kCFStringEncodingInvalidId) (#/defaultCStringEncoding ns:ns-string) ns))))))) (defclass hemlock-document-controller (ns:ns-document-controller) ((last-encoding :foreign-type :tringncoding)) (:metaclass ns:+ns-object)) (declaim (special hemlock-document-controller)) (objc:defmethod #/init ((self hemlock-document-controller)) (prog1 (call-next-method) (setf (slot-value self 'last-encoding) 0))) ;;; The HemlockEditorDocument class. (defclass hemlock-editor-document (ns:ns-document) ((textstorage :foreign-type :id) (encoding :foreign-type :tringncoding :initform (get-default-encoding))) (:metaclass ns:+ns-object)) (defmethod hemlock-buffer ((self hemlock-editor-document)) (let ((ts (slot-value self 'textstorage))) (unless (%null-ptr-p ts) (hemlock-buffer ts)))) (defmethod assume-not-editing ((doc hemlock-editor-document)) (assume-not-editing (slot-value doc 'textstorage))) (defmethod document-invalidate-modeline ((self hemlock-editor-document)) (for-each-textview-using-storage (slot-value self 'textstorage) #'(lambda (tv) (let* ((pane (text-view-pane tv))) (unless (%null-ptr-p pane) (#/setNeedsDisplay: (text-pane-mode-line pane) t)))))) (defmethod update-buffer-package ((doc hemlock-editor-document) buffer) (let* ((name (hemlock::package-at-mark (hi::buffer-point buffer)))) (when name (let* ((pkg (find-package name))) (if pkg (setq name (shortest-package-name pkg)))) (let* ((curname (hi::variable-value 'hemlock::current-package :buffer buffer))) (if (or (null curname) (not (string= curname name))) (setf (hi::variable-value 'hemlock::current-package :buffer buffer) name)))))) (defun hemlock-ext:note-selection-set-by-search (buffer) (let* ((doc (hi::buffer-document buffer))) (when doc (with-slots (textstorage) doc (when textstorage (with-slots (selection-set-by-search) textstorage (setq selection-set-by-search #$YES))))))) (objc:defmethod (#/validateMenuItem: :) ((self hemlock-text-view) item) (let* ((action (#/action item))) #+debug (#_NSLog #@"action = %s" :address action) (cond ((eql action (@selector #/hyperSpecLookUp:)) ;; For now, demand a selection. (and *hyperspec-lookup-enabled* (hyperspec-root-url) (not (eql 0 (ns:ns-range-length (#/selectedRange self)))))) ((eql action (@selector #/cut:)) (let* ((selection (#/selectedRange self))) (and (> (ns:ns-range-length selection)) (#/shouldChangeTextInRange:replacementString: self selection #@"")))) ((eql action (@selector #/evalSelection:)) (not (eql 0 (ns:ns-range-length (#/selectedRange self))))) ;; if this hemlock-text-view is in an editor windowm and its buffer has ;; an associated pathname, then activate the Load Buffer item ((or (eql action (@selector #/loadBuffer:)) (eql action (@selector #/compileBuffer:)) (eql action (@selector #/compileAndLoadBuffer:))) (let* ((buffer (hemlock-buffer self)) (pathname (hi::buffer-pathname buffer))) (not (null pathname)))) (t (call-next-method item))))) (defmethod user-input-style ((doc hemlock-editor-document)) 0) (defvar *encoding-name-hash* (make-hash-table)) (defmethod document-encoding-name ((doc hemlock-editor-document)) (with-slots (encoding) doc (if (eql encoding 0) "Automatic" (or (gethash encoding *encoding-name-hash*) (setf (gethash encoding *encoding-name-hash*) (lisp-string-from-nsstring (nsstring-for-nsstring-encoding encoding))))))) (defun hi::buffer-encoding-name (buffer) (let ((doc (hi::buffer-document buffer))) (and doc (document-encoding-name doc)))) ;; TODO: make each buffer have a slot, and this is just the default value. (defmethod textview-background-color ((doc hemlock-editor-document)) *editor-background-color*) (objc:defmethod (#/setTextStorage: :void) ((self hemlock-editor-document) ts) (let* ((doc (%inc-ptr self 0)) ; workaround for stack-consed self (string (#/hemlockString ts)) (cache (hemlock-buffer-string-cache string)) (buffer (buffer-cache-buffer cache))) (unless (%null-ptr-p doc) (setf (slot-value doc 'textstorage) ts (hi::buffer-document buffer) doc)))) ;; This runs on the main thread. (objc:defmethod (#/revertToSavedFromFile:ofType: :) ((self hemlock-editor-document) filename filetype) (declare (ignore filetype)) (assume-cocoa-thread) #+debug (#_NSLog #@"revert to saved from file %@ of type %@" :id filename :id filetype) (let* ((encoding (slot-value self 'encoding)) (nsstring (make-instance ns:ns-string :with-contents-of-file filename :encoding encoding :error +null-ptr+)) (buffer (hemlock-buffer self)) (old-length (hemlock-buffer-length buffer)) (hi::*current-buffer* buffer) (textstorage (slot-value self 'textstorage)) (point (hi::buffer-point buffer)) (pointpos (hi:mark-absolute-position point))) (hemlock-ext:invoke-modifying-buffer-storage buffer #'(lambda () (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length)) (nsstring-to-buffer nsstring buffer) (let* ((newlen (hemlock-buffer-length buffer))) (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen) (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0) (let* ((ts-string (#/hemlockString textstorage)) (display (hemlock-buffer-string-cache ts-string))) (reset-buffer-cache display) (update-line-cache-for-index display 0) (move-hemlock-mark-to-absolute-position point display (min newlen pointpos)))) (#/updateMirror textstorage) (setf (hi::buffer-modified buffer) nil) (hi::note-modeline-change buffer))) t)) (defvar *last-document-created* nil) (objc:defmethod #/init ((self hemlock-editor-document)) (let* ((doc (call-next-method))) (unless (%null-ptr-p doc) (#/setTextStorage: doc (make-textstorage-for-hemlock-buffer (make-hemlock-buffer (lisp-string-from-nsstring (#/displayName doc)) :modes '("Lisp" "Editor"))))) (setq *last-document-created* doc) doc)) (defun make-buffer-for-document (ns-document pathname) (let* ((buffer-name (hi::pathname-to-buffer-name pathname)) (buffer (make-hemlock-buffer buffer-name))) (setf (slot-value ns-document 'textstorage) (make-textstorage-for-hemlock-buffer buffer)) (setf (hi::buffer-pathname buffer) pathname) buffer)) (objc:defmethod (#/readFromURL:ofType:error: :) ((self hemlock-editor-document) url type (perror (:* :id))) (declare (ignorable type)) (with-callback-context "readFromURL" (rlet ((pused-encoding :tringncoding 0)) (let* ((pathname (lisp-string-from-nsstring (if (#/isFileURL url) (#/path url) (#/absoluteString url)))) (buffer (or (hemlock-buffer self) (make-buffer-for-document self pathname))) (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding)) (string (if (zerop selected-encoding) (#/stringWithContentsOfURL:usedEncoding:error: ns:ns-string url pused-encoding perror) +null-ptr+))) (if (%null-ptr-p string) (progn (if (zerop selected-encoding) (setq selected-encoding (get-default-encoding))) (setq string (#/stringWithContentsOfURL:encoding:error: ns:ns-string url selected-encoding perror))) (setq selected-encoding (pref pused-encoding :tringncoding))) (unless (%null-ptr-p string) (with-slots (encoding) self (setq encoding selected-encoding)) ;; ** TODO: Argh. How about we just let hemlock insert it. (let* ((textstorage (slot-value self 'textstorage)) (display (hemlock-buffer-string-cache (#/hemlockString textstorage))) (hi::*current-buffer* buffer)) (hemlock-ext:invoke-modifying-buffer-storage buffer #'(lambda () (nsstring-to-buffer string buffer) (reset-buffer-cache display) (#/updateMirror textstorage) (update-line-cache-for-index display 0) (textstorage-note-insertion-at-position textstorage 0 (hemlock-buffer-length buffer)) (hi::note-modeline-change buffer) (setf (hi::buffer-modified buffer) nil)))) t))))) (def-cocoa-default *editor-keep-backup-files* :bool t "maintain backup files") (objc:defmethod (#/keepBackupFile :) ((self hemlock-editor-document)) ;;; Don't use the NSDocument backup file scheme. nil) (objc:defmethod (#/writeSafelyToURL:ofType:forSaveOperation:error: :) ((self hemlock-editor-document) absolute-url type (save-operation :aveperationype) (error (:* :id))) (when (and *editor-keep-backup-files* (eql save-operation #$NSSaveOperation)) (write-hemlock-backup-file (#/fileURL self))) (call-next-method absolute-url type save-operation error)) (defun write-hemlock-backup-file (url) (unless (%null-ptr-p url) (when (#/isFileURL url) (let* ((path (#/path url))) (unless (%null-ptr-p path) (let* ((newpath (#/stringByAppendingString: path #@"~")) (fm (#/defaultManager ns:ns-file-manager))) ;; There are all kinds of ways for this to lose. ;; In order for the copy to succeed, the destination can't exist. ;; (It might exist, but be a directory, or there could be ;; permission problems ...) (#/removeFileAtPath:handler: fm newpath +null-ptr+) (#/copyPath:toPath:handler: fm path newpath +null-ptr+))))))) (defmethod hemlock-view ((frame hemlock-frame)) (let ((pane (slot-value frame 'pane))) (when (and pane (not (%null-ptr-p pane))) (hemlock-view pane)))) (defun hemlock-ext:all-hemlock-views () "List of all hemlock views, in z-order, frontmost first" (loop for win in (windows) as buf = (and (typep win 'hemlock-frame) (hemlock-view win)) when buf collect buf)) (defmethod hi::document-panes ((document hemlock-editor-document)) (let* ((ts (slot-value document 'textstorage)) (panes ())) (for-each-textview-using-storage ts #'(lambda (tv) (let* ((pane (text-view-pane tv))) (unless (%null-ptr-p pane) (push pane panes))))) panes)) (objc:defmethod (#/noteEncodingChange: :void) ((self hemlock-editor-document) popup) (with-slots (encoding) self (setq encoding (nsinteger-to-nsstring-encoding (#/selectedTag popup))) (hi::note-modeline-change (hemlock-buffer self)))) (objc:defmethod (#/prepareSavePanel: :) ((self hemlock-editor-document) panel) (with-slots (encoding) self (let* ((popup (build-encodings-popup (#/sharedDocumentController hemlock-document-controller) encoding))) (#/setAction: popup (@selector #/noteEncodingChange:)) (#/setTarget: popup self) (#/setAccessoryView: panel popup))) (#/setExtensionHidden: panel nil) (#/setCanSelectHiddenExtension: panel nil) (#/setAllowedFileTypes: panel +null-ptr+) (call-next-method panel)) (defloadvar *ns-cr-string* (%make-nsstring (string #\return))) (defloadvar *ns-lf-string* (%make-nsstring (string #\linefeed))) (defloadvar *ns-crlf-string* (with-autorelease-pool (#/retain (#/stringByAppendingString: *ns-cr-string* *ns-lf-string*)))) (objc:defmethod (#/writeToURL:ofType:error: :) ((self hemlock-editor-document) url type (error (:* :id))) (declare (ignore type)) (with-slots (encoding textstorage) self (let* ((string (#/string textstorage)) (buffer (hemlock-buffer self))) (case (when buffer (hi::buffer-line-termination buffer)) (:crlf (unless (typep string 'ns:ns-mutable-string) (setq string (make-instance 'ns:ns-mutable-string :with string string)) (#/replaceOccurrencesOfString:withString:options:range: string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))) (:cr (setq string (if (typep string 'ns:ns-mutable-string) string (make-instance 'ns:ns-mutable-string :with string string))) (#/replaceOccurrencesOfString:withString:options:range: string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))) (when (#/writeToURL:atomically:encoding:error: string url t encoding error) (when buffer (setf (hi::buffer-modified buffer) nil)) t)))) ;;; Shadow the setFileURL: method, so that we can keep the buffer ;;; name and pathname in synch with the document. (objc:defmethod (#/setFileURL: :void) ((self hemlock-editor-document) url) (call-next-method url) (let* ((buffer (hemlock-buffer self))) (when buffer (let* ((new-pathname (lisp-string-from-nsstring (#/path url)))) (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname)) (setf (hi::buffer-pathname buffer) new-pathname))))) (def-cocoa-default *initial-editor-x-pos* :float 20.0f0 "X position of upper-left corner of initial editor") (def-cocoa-default *initial-editor-y-pos* :float -20.0f0 "Y position of upper-left corner of initial editor") (defloadvar *next-editor-x-pos* nil) ; set after defaults initialized (defloadvar *next-editor-y-pos* nil) (defun x-pos-for-window (window x) (let* ((frame (#/frame window)) (screen (#/screen window))) (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen))) (let* ((screen-rect (#/visibleFrame screen))) (if (>= x 0) (+ x (ns:ns-rect-x screen-rect)) (- (+ (ns:ns-rect-width screen-rect) x) (ns:ns-rect-width frame)))))) (defun y-pos-for-window (window y) (let* ((frame (#/frame window)) (screen (#/screen window))) (if (%null-ptr-p screen) (setq screen (#/mainScreen ns:ns-screen))) (let* ((screen-rect (#/visibleFrame screen))) (if (>= y 0) (+ y (ns:ns-rect-y screen-rect) (ns:ns-rect-height frame)) (+ (ns:ns-rect-height screen-rect) y))))) (objc:defmethod (#/makeWindowControllers :void) ((self hemlock-editor-document)) #+debug (#_NSLog #@"Make window controllers") (with-callback-context "makeWindowControllers" (let* ((textstorage (slot-value self 'textstorage)) (window (%hemlock-frame-for-textstorage hemlock-frame textstorage *editor-columns* *editor-rows* nil (textview-background-color self) (user-input-style self))) (controller (make-instance 'hemlock-editor-window-controller :with-window window))) (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self) (#/addWindowController: self controller) (#/release controller) (ns:with-ns-point (current-point (or *next-editor-x-pos* (x-pos-for-window window *initial-editor-x-pos*)) (or *next-editor-y-pos* (y-pos-for-window window *initial-editor-y-pos*))) (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point))) (setq *next-editor-x-pos* (ns:ns-point-x new-point) *next-editor-y-pos* (ns:ns-point-y new-point)))) (let ((view (hemlock-view window))) (hi::handle-hemlock-event view #'(lambda () (hi::process-file-options))))))) (objc:defmethod (#/close :void) ((self hemlock-editor-document)) #+debug (#_NSLog #@"Document close: %@" :id self) (let* ((textstorage (slot-value self 'textstorage))) (unless (%null-ptr-p textstorage) (setf (slot-value self 'textstorage) (%null-ptr)) (for-each-textview-using-storage textstorage #'(lambda (tv) (let* ((layout (#/layoutManager tv))) (#/setBackgroundLayoutEnabled: layout nil)))) (close-hemlock-textstorage textstorage))) (call-next-method)) (defmethod view-screen-lines ((view hi:hemlock-view)) (let* ((pane (hi::hemlock-view-pane view))) (floor (ns:ns-size-height (#/contentSize (text-pane-scroll-view pane))) (text-view-line-height (text-pane-text-view pane))))) ;; Beware this doesn't seem to take horizontal scrolling into account. (defun visible-charpos-range (tv) (let* ((rect (#/visibleRect tv)) (container-origin (#/textContainerOrigin tv)) (layout (#/layoutManager tv))) ;; Convert from view coordinates to container coordinates (decf (pref rect :ect.origin.x) (pref container-origin :oint.x)) (decf (pref rect :ect.origin.y) (pref container-origin :oint.y)) (let* ((glyph-range (#/glyphRangeForBoundingRect:inTextContainer: layout rect (#/textContainer tv))) (char-range (#/characterRangeForGlyphRange:actualGlyphRange: layout glyph-range +null-ptr+))) (values (pref char-range :ange.location) (pref char-range :ange.length))))) (defun charpos-xy (tv charpos) (let* ((layout (#/layoutManager tv)) (glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange: layout (ns:make-ns-range charpos 0) +null-ptr+)) (rect (#/boundingRectForGlyphRange:inTextContainer: layout glyph-range (#/textContainer tv))) (container-origin (#/textContainerOrigin tv))) (values (+ (pref rect :ect.origin.x) (pref container-origin :oint.x)) (+ (pref rect :ect.origin.y) (pref container-origin :oint.y))))) ;;(nth-value 1 (charpos-xy tv (visible-charpos-range tv))) - this is smaller as it ;; only includes lines fully scrolled off... (defun text-view-vscroll (tv) ;; Return the number of pixels scrolled off the top of the view. (let* ((scroll-view (text-pane-scroll-view (text-view-pane tv))) (clip-view (#/contentView scroll-view)) (bounds (#/bounds clip-view))) (ns:ns-rect-y bounds))) (defun set-text-view-vscroll (tv vscroll) (let* ((scroll-view (text-pane-scroll-view (text-view-pane tv))) (clip-view (#/contentView scroll-view)) (bounds (#/bounds clip-view))) (decf vscroll (mod vscroll (text-view-line-height tv))) ;; show whole line (ns:with-ns-point (new-origin (ns:ns-rect-x bounds) vscroll) (#/scrollToPoint: clip-view (#/constrainScrollPoint: clip-view new-origin)) (#/reflectScrolledClipView: scroll-view clip-view)))) (defun scroll-by-lines (tv nlines) "Change the vertical origin of the containing scrollview's clipview" (set-text-view-vscroll tv (+ (text-view-vscroll tv) (* nlines (text-view-line-height tv))))) ;; TODO: should be a hemlock variable.. (defvar *next-screen-context-lines* 2) (defmethod hemlock-ext:scroll-view ((view hi:hemlock-view) how &optional where) (assume-cocoa-thread) (let* ((tv (text-pane-text-view (hi::hemlock-view-pane view)))) (when (eq how :line) (setq where (require-type where '(integer 0))) (let* ((line-y (nth-value 1 (charpos-xy tv where))) (top-y (text-view-vscroll tv)) (nlines (floor (- line-y top-y) (text-view-line-height tv)))) (setq how :lines-down where nlines))) (ecase how (:center-selection (#/centerSelectionInVisibleArea: tv +null-ptr+)) (:page-up (require-type where 'null) ;; TODO: next-screen-context-lines (scroll-by-lines tv (- *next-screen-context-lines* (view-screen-lines view)))) (:page-down (require-type where 'null) (scroll-by-lines tv (- (view-screen-lines view) *next-screen-context-lines*))) (:lines-up (scroll-by-lines tv (- (require-type where 'integer)))) (:lines-down (scroll-by-lines tv (require-type where 'integer)))) ;; If point is not on screen, move it. (let* ((point (hi::current-point)) (point-pos (hi::mark-absolute-position point))) (multiple-value-bind (win-pos win-len) (visible-charpos-range tv) (unless (and (<= win-pos point-pos) (< point-pos (+ win-pos win-len))) (let* ((point (hi::current-point-collapsing-selection)) (cache (hemlock-buffer-string-cache (#/hemlockString (#/textStorage tv))))) (move-hemlock-mark-to-absolute-position point cache win-pos) (update-hemlock-selection (#/textStorage tv)))))))) (defun iana-charset-name-of-nsstringencoding (ns) (#_CFStringConvertEncodingToIANACharSetName (#_CFStringConvertNSStringEncodingToEncoding ns))) (defun nsstring-for-nsstring-encoding (ns) (let* ((iana (iana-charset-name-of-nsstringencoding ns))) (if (%null-ptr-p iana) (#/stringWithFormat: ns:ns-string #@"{%@}" (#/localizedNameOfStringEncoding: ns:ns-string ns)) iana))) ;;; Return a list of :tringncodings, sorted by the ;;; (localized) name of each encoding. (defun supported-nsstring-encodings () (ccl::collect ((ids)) (let* ((ns-ids (#/availableStringEncodings ns:ns-string))) (unless (%null-ptr-p ns-ids) (do* ((i 0 (1+ i))) () (let* ((id (paref ns-ids (:* :tringncoding) i))) (if (zerop id) (return (sort (ids) #'(lambda (x y) (= #$NSOrderedAscending (#/localizedCompare: (nsstring-for-nsstring-encoding x) (nsstring-for-nsstring-encoding y)))))) (ids id)))))))) ;;; TexEdit.app has support for allowing the encoding list in this ;;; popup to be customized (e.g., to suppress encodings that the ;;; user isn't interested in.) (defmethod build-encodings-popup ((self hemlock-document-controller) &optional (preferred-encoding (get-default-encoding))) (let* ((id-list (supported-nsstring-encodings)) (popup (make-instance 'ns:ns-pop-up-button))) ;;; Add a fake "Automatic" item with tag 0. (#/addItemWithTitle: popup #@"Automatic") (#/setTag: (#/itemAtIndex: popup 0) 0) (dolist (id id-list) (#/addItemWithTitle: popup (nsstring-for-nsstring-encoding id)) (#/setTag: (#/lastItem popup) (nsstring-encoding-to-nsinteger id))) (when preferred-encoding (#/selectItemWithTag: popup (nsstring-encoding-to-nsinteger preferred-encoding))) (#/sizeToFit popup) popup)) (objc:defmethod (#/runModalOpenPanel:forTypes: :nteger) ((self hemlock-document-controller) panel types) (let* ((popup (build-encodings-popup self #|preferred|#))) (#/setAccessoryView: panel popup) (let* ((result (call-next-method panel types))) (when (= result #$NSOKButton) (with-slots (last-encoding) self (setq last-encoding (nsinteger-to-nsstring-encoding (#/tag (#/selectedItem popup)))))) result))) (defun hi::open-document () (#/performSelectorOnMainThread:withObject:waitUntilDone: (#/sharedDocumentController hemlock-document-controller) (@selector #/openDocument:) +null-ptr+ t)) (defmethod hi::save-hemlock-document ((self hemlock-editor-document)) (#/performSelectorOnMainThread:withObject:waitUntilDone: self (@selector #/saveDocument:) +null-ptr+ t)) (defmethod hi::save-hemlock-document-as ((self hemlock-editor-document)) (#/performSelectorOnMainThread:withObject:waitUntilDone: self (@selector #/saveDocumentAs:) +null-ptr+ t)) (defmethod hi::save-hemlock-document-to ((self hemlock-editor-document)) (#/performSelectorOnMainThread:withObject:waitUntilDone: self (@selector #/saveDocumentTo:) +null-ptr+ t)) (defun initialize-user-interface () ;; The first created instance of an NSDocumentController (or ;; subclass thereof) becomes the shared document controller. So it ;; may look like we're dropping this instance on the floor, but ;; we're really not. (make-instance 'hemlock-document-controller) ;(#/sharedPanel lisp-preferences-panel) (make-editor-style-map)) ;;; This needs to run on the main thread. Sets the cocoa selection from the ;;; hemlock selection. (defmethod update-hemlock-selection ((self hemlock-text-storage)) (assume-cocoa-thread) (let ((buffer (hemlock-buffer self))) (multiple-value-bind (start end) (hi:buffer-selection-range buffer) #+debug (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d" :int (hi::mark-charpos (hi::buffer-point buffer)) :int start) (for-each-textview-using-storage self #'(lambda (tv) (#/updateSelection:length:affinity: tv start (- end start) (if (eql start 0) #$NSSelectionAffinityUpstream #$NSSelectionAffinityDownstream))))))) ;; This should be invoked by any command that modifies the buffer, so it can show the ;; user what happened... This ensures the Cocoa selection is made visible, so it ;; assumes the Cocoa selection has already been synchronized with the hemlock one. (defmethod hemlock-ext:ensure-selection-visible ((view hi:hemlock-view)) (let ((tv (text-pane-text-view (hi::hemlock-view-pane view)))) (#/scrollRangeToVisible: tv (#/selectedRange tv)))) (defloadvar *general-pasteboard* nil) (defun general-pasteboard () (or *general-pasteboard* (setq *general-pasteboard* (#/retain (#/generalPasteboard ns:ns-pasteboard))))) (defloadvar *string-pasteboard-types* ()) (defun string-pasteboard-types () (or *string-pasteboard-types* (setq *string-pasteboard-types* (#/retain (#/arrayWithObject: ns:ns-array #&NSStringPboardType))))) (objc:defmethod (#/stringToPasteBoard: :void) ((self lisp-application) string) (let* ((pb (general-pasteboard))) (#/declareTypes:owner: pb (string-pasteboard-types) nil) (#/setString:forType: pb string #&NSStringPboardType))) (defun hi::string-to-clipboard (string) (when (> (length string) 0) (#/performSelectorOnMainThread:withObject:waitUntilDone: *nsapp* (@selector #/stringToPasteBoard:) (%make-nsstring string) t))) ;;; The default #/paste method seems to want to set the font to ;;; something ... inappropriate. If we can figure out why it ;;; does that and persuade it not to, we wouldn't have to do ;;; this here. ;;; (It's likely to also be the case that Carbon applications ;;; terminate lines with #\Return when writing to the clipboard; ;;; we may need to continue to override this method in order to ;;; fix that.) (objc:defmethod (#/paste: :void) ((self hemlock-text-view) sender) (declare (ignorable sender)) #+debug (#_NSLog #@"Paste: sender = %@" :id sender) (let* ((pb (general-pasteboard)) (string (progn (#/types pb) (#/stringForType: pb #&NSStringPboardType)))) #+GZ (log-debug " string = ~s" string) (unless (%null-ptr-p string) (unless (zerop (ns:ns-range-length (#/rangeOfString: string *ns-cr-string*))) (setq string (make-instance 'ns:ns-mutable-string :with-string string)) (#/replaceOccurrencesOfString:withString:options:range: string *ns-cr-string* *ns-lf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))) (let* ((textstorage (#/textStorage self))) (unless (#/shouldChangeTextInRange:replacementString: self (#/selectedRange self) string) (#/setSelectedRange: self (ns:make-ns-range (#/length textstorage) 0))) (let* ((selectedrange (#/selectedRange self))) (#/replaceCharactersInRange:withString: textstorage selectedrange string)))))) (objc:defmethod (#/hyperSpecLookUp: :void) ((self hemlock-text-view) sender) (declare (ignore sender)) (let* ((range (#/selectedRange self))) (unless (eql 0 (ns:ns-range-length range)) (let* ((string (nstring-upcase (lisp-string-from-nsstring (#/substringWithRange: (#/string (#/textStorage self)) range))))) (multiple-value-bind (symbol win) (find-symbol string "CL") (when win (lookup-hyperspec-symbol symbol self))))))) ;; This is called by stuff that makes a window programmatically, e.g. m-. or grep. ;; But the Open and New menus invoke the cocoa fns below directly. So just changing ;; things here will not change how the menus create views. Instead,f make changes to ;; the subfunctions invoked by the below, e.g. #/readFromURL or #/makeWindowControllers. (defun find-or-make-hemlock-view (&optional pathname) (assume-cocoa-thread) (rlet ((perror :id +null-ptr+)) (let* ((doc (if pathname (#/openDocumentWithContentsOfURL:display:error: (#/sharedDocumentController ns:ns-document-controller) (pathname-to-url pathname) #$YES perror) (let ((*last-document-created* nil)) (#/newDocument: (#/sharedDocumentController hemlock-document-controller) +null-ptr+) *last-document-created*)))) #+gz (log-debug "created ~s" doc) (when (%null-ptr-p doc) (error "Couldn't open ~s: ~a" pathname (let ((error (pref perror :id))) (if (%null-ptr-p error) "unknown error encountered" (lisp-string-from-nsstring (#/localizedDescription error)))))) (front-view-for-buffer (hemlock-buffer doc))))) (defun cocoa-edit-single-definition (name info) (assume-cocoa-thread) (destructuring-bind (indicator . pathname) info (let ((view (find-or-make-hemlock-view pathname))) (hi::handle-hemlock-event view #'(lambda () (hemlock::find-definition-in-buffer name indicator)))))) (defun hemlock-ext:edit-single-definition (name info) (execute-in-gui #'(lambda () (cocoa-edit-single-definition name info)))) (defun hemlock-ext:open-sequence-dialog (&key title sequence action (printer #'prin1)) (make-instance 'sequence-window-controller :title title :sequence sequence :result-callback action :display printer)) (objc:defmethod (#/documentClassForType: :lass) ((self hemlock-document-controller) type) (if (#/isEqualToString: type #@"html") display-document (call-next-method type))) (objc:defmethod #/newDisplayDocumentWithTitle:content: ((self hemlock-document-controller) title string) (assume-cocoa-thread) (let* ((doc (#/makeUntitledDocumentOfType:error: self #@"html" +null-ptr+))) (unless (%null-ptr-p doc) (#/addDocument: self doc) (#/makeWindowControllers doc) (let* ((window (#/window (#/objectAtIndex: (#/windowControllers doc) 0)))) (#/setTitle: window title) (let* ((tv (slot-value doc 'text-view)) (lm (#/layoutManager tv)) (ts (#/textStorage lm))) (#/beginEditing ts) (#/replaceCharactersInRange:withAttributedString: ts (ns:make-ns-range 0 (#/length ts)) string) (#/endEditing ts)) (#/makeKeyAndOrderFront: window self))) doc)) (defun hi::revert-document (doc) (#/performSelectorOnMainThread:withObject:waitUntilDone: doc (@selector #/revertDocumentToSaved:) +null-ptr+ t)) (defun hemlock-ext:raise-buffer-view (buffer &optional action) "Bring a window containing buffer to front and then execute action in the window. Returns before operation completes." ;; Queue for after this event, so don't screw up current context. (queue-for-gui #'(lambda () (let ((doc (hi::buffer-document buffer))) (unless (and doc (not (%null-ptr-p doc))) (hi:editor-error "Deleted buffer: ~s" buffer)) (#/showWindows doc) (when action (hi::handle-hemlock-event (front-view-for-buffer buffer) action)))))) ;;; Enable CL:ED (defun cocoa-edit (&optional arg) (cond ((or (null arg) (typep arg 'string) (typep arg 'pathname)) (when arg (unless (probe-file arg) (let ((lpath (merge-pathnames arg *.lisp-pathname*))) (when (probe-file lpath) (setq arg lpath))))) (execute-in-gui #'(lambda () (find-or-make-hemlock-view arg)))) ((ccl::valid-function-name-p arg) (hemlock::edit-definition arg) nil) (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p)))))) (setq ccl::*resident-editor-hook* 'cocoa-edit)