Index: /branches/ide-1.0/ccl/examples/cocoa-editor.lisp =================================================================== --- /branches/ide-1.0/ccl/examples/cocoa-editor.lisp (revision 6723) +++ /branches/ide-1.0/ccl/examples/cocoa-editor.lisp (revision 6724) @@ -28,13 +28,6 @@ (def-cocoa-default *editor-columns* :int 80 "Initial width of editor windows, in characters") -;;; Background color components: red, blue, green, alpha. -;;; All should be single-floats between 0.0f0 and 1.0f0, inclusive. -(def-cocoa-default *editor-background-red-component* :float 1.0f0 "Red component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") -(def-cocoa-default *editor-background-green-component* :float 1.0f0 "Green component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") -(def-cocoa-default *editor-background-blue-component* :float 1.0f0 "Blue component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") -(def-cocoa-default *editor-background-alpha-component* :float 1.0f0 "Alpha component of editor background color. Should be a float between 0.0 and 1.0, inclusive.") - -;;; At runtime, this'll be a vector of character attribute dictionaries. -(defloadvar *styles* ()) +(def-cocoa-default *editor-background-color* :color (#/whiteColor ns:ns-color) "Editor background color") + (defun make-editor-style-map () @@ -57,5 +50,6 @@ (#/greenColor color-class) (#/yellowColor color-class))) - (styles (make-array (the fixnum (* 4 (length colors))))) + (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))) @@ -66,16 +60,17 @@ (dotimes (i 4) (let* ((mask (logand i 3))) - (setf (svref styles s) (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))))) + (#/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))) - (setq *styles* styles))) + (#/retain styles))) (defun make-hemlock-buffer (&rest args) @@ -374,5 +369,6 @@ (edit-count :foreign-type :int) (append-edits :foreign-type :int) - (cache :foreign-type :id)) + (cache :foreign-type :id) + (styles :foreign-type :id)) (:metaclass ns:+ns-object)) @@ -465,13 +461,18 @@ (objc:defmethod #/hemlockString ((self hemlock-text-storage)) -(slot-value self 'hemlock-string)) + (slot-value self 'hemlock-string)) + +(objc:defmethod #/styles ((self hemlock-text-storage)) + (slot-value self 'styles)) (objc:defmethod #/initWithString: ((self hemlock-text-storage) s) (setq s (%inc-ptr s 0)) (let* ((newself (#/init self)) + (styles (make-editor-style-map)) (cache (#/retain (make-instance ns:ns-mutable-attributed-string :with-string s - :attributes (svref *styles* 0))))) + :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 'cache) cache) @@ -481,7 +482,7 @@ ;;; Should generally only be called after open/revert. (objc:defmethod (#/updateCache :void) ((self hemlock-text-storage)) - (with-slots (hemlock-string cache) self + (with-slots (hemlock-string cache styles) self (#/replaceCharactersInRange:withString: cache (ns:make-ns-range 0 (#/length cache)) hemlock-string) - (#/setAttributes:range: cache (svref *styles* 0) (ns:make-ns-range 0 (#/length cache))))) + (#/setAttributes:range: cache (#/objectAtIndex: styles 0) (ns:make-ns-range 0 (#/length cache))))) ;;; This is the only thing that's actually called to create a @@ -502,5 +503,5 @@ #+debug (#_NSLog #@"Attributes at index: %d storage %@" :unsigned index :id self) - (with-slots (cache) self + (with-slots (cache styles) self (let* ((attrs (#/attributesAtIndex:effectiveRange: cache index rangeptr))) (when (eql 0 (#/count attrs)) @@ -509,5 +510,5 @@ (#/attributesAtIndex:longestEffectiveRange:inRange: cache index r (ns:make-ns-range 0 (#/length cache))) - (setq attrs (svref *styles* 0)) + (setq attrs (#/objectAtIndex: styles 0)) (#/setAttributes:range: cache attrs r))) attrs))) @@ -539,6 +540,9 @@ (when textstorage (#/endEditing textstorage) - (for-each-textview-using-storage textstorage (lambda (tv) - (hi::disable-self-insert (hemlock-frame-event-queue (#/window tv))))) + (for-each-textview-using-storage + textstorage + (lambda (tv) + (hi::disable-self-insert + (hemlock-frame-event-queue (#/window tv))))) (#/ensureSelectionVisible textstorage))))) @@ -579,6 +583,11 @@ (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)) @@ -626,4 +635,7 @@ (:metaclass ns:+ns-object)) +(objc:defmethod (#/changeColor: :void) ((self hemlock-textstorage-text-view) + sender) + (#_NSLog #@"Change color to = %@" :id (#/color sender))) (def-cocoa-default *layout-text-in-background* :int 1 "When non-zero, do text layout when idle.") @@ -1153,8 +1165,9 @@ (#/setAutoresizingMask: tv #$NSViewWidthSizable) (#/setBackgroundColor: tv color) - (#/setTypingAttributes: tv (aref *styles* style)) + (#/setTypingAttributes: tv (#/objectAtIndex: (#/styles textstorage) style)) (#/setSmartInsertDeleteEnabled: tv nil) (#/setAllowsUndo: tv nil) ; don't want NSTextView undo (#/setUsesFindPanel: tv t) + (#/setUsesFontPanel: tv t) (#/setWidthTracksTextView: container tracks-width) (#/setHeightTracksTextView: container nil) @@ -1594,10 +1607,11 @@ (let* ((document (hi::buffer-document buffer)) (textstorage (if document (slot-value document 'textstorage))) + (styles (#/styles textstorage)) (cache (#/cache textstorage)) (pos (mark-absolute-position (hi::region-start region))) (n (- (mark-absolute-position (hi::region-end region)) pos))) #+debug - (#_NSLog #@"Setting font attributes for %d/%d to %@" :int pos :int n :id (svref *styles* font)) - (#/setAttributes:range: cache (svref *styles* font) (ns:make-ns-range pos n)) + (#_NSLog #@"Setting font attributes for %d/%d to %@" :int pos :int n :id (#/objectAtIndex: styles font)) + (#/setAttributes:range: cache (#/objectAtIndex: styles font) (ns:make-ns-range pos n)) (perform-edit-change-notification textstorage (@selector #/noteAttrChange:) @@ -1607,9 +1621,11 @@ (defun buffer-active-font (buffer) (let* ((style 0) - (region (hi::buffer-active-font-region buffer))) + (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)))) - (svref *styles* style))) + (#/objectAtIndex: styles style))) (defun hi::buffer-note-insertion (buffer mark n) @@ -1802,10 +1818,5 @@ (defmethod textview-background-color ((doc hemlock-editor-document)) - (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color - (float *editor-background-red-component* - +cgfloat-zero+) - (float *editor-background-green-component* +cgfloat-zero+) - (float *editor-background-blue-component* +cgfloat-zero+) - (float *editor-background-alpha-component* +cgfloat-zero+))) + *editor-background-color*) @@ -1984,8 +1995,13 @@ (buffer (hemlock-document-buffer self))) (case (when buffer (hi::buffer-line-termination buffer)) - (:cp/m (setq string (#/stringByReplacingOccurrencesOfString:withString: - string *ns-lf-string* *ns-crlf-string*))) - (:macos (setq string (#/stringByReplacingOccurrencesOfString:withString: - string *ns-lf-string* *ns-cr-string*)))) + (:cp/m (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))))) + (:macos (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) @@ -2193,6 +2209,5 @@ (defun initialize-user-interface () (#/sharedDocumentController hemlock-document-controller) - (#/sharedPanel preferences-panel) - (update-cocoa-defaults) + (#/sharedPanel lisp-preferences-panel) (make-editor-style-map)) @@ -2271,5 +2286,8 @@ (unless (%null-ptr-p string) (unless (zerop (ns:ns-range-length (#/rangeOfString: string *ns-cr-string*))) - (setq string (#/stringByReplacingOccurrencesOfString:withString: string *ns-cr-string* *ns-lf-string*))) + (unless (typep string 'ns:ns-mutable-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)) (selectedrange (#/selectedRange self)))