Changeset 744
- Timestamp:
- Mar 27, 2004, 2:58:26 AM (21 years ago)
- File:
-
- 1 edited
-
trunk/ccl/examples/cocoa-editor.lisp (modified) (26 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/examples/cocoa-editor.lisp
r721 r744 13 13 (def-cocoa-default *editor-rows* :int 24) 14 14 (def-cocoa-default *editor-columns* :int 80) 15 16 ;;; Background color components: red, blue, green, alpha. 17 ;;; All should be single-floats between 0.0f0 and 1.0f0, inclusive. 18 (def-cocoa-default *editor-background-red-component* :int 1.0f0) 19 (def-cocoa-default *editor-background-blue-component* :int 1.0f0) 20 (def-cocoa-default *editor-background-green-component* :int 1.0f0) 21 (def-cocoa-default *editor-background-alpha-component* :int 1.0f0) 15 22 16 23 ;;; At runtime, this'll be a vector of character attribute dictionaries. … … 308 315 (:metaclass ns:+ns-object)) 309 316 310 (define-objc-method ((:void begin-editing) hemlock-text-storage)311 #+debug312 (#_NSLog #@"begin-editing")313 (incf (slot-value self 'edit-count))314 (send-super 'begin-editing))315 316 (define-objc-method ((:void end-editing) hemlock-text-storage)317 #+debug318 (#_NSLog #@"end-editing")319 (send-super 'end-editing)320 (decf (slot-value self 'edit-count)))321 317 322 318 ;;; Return true iff we're inside a "beginEditing/endEditing" pair … … 353 349 (let* ((pos (send (send params :object-at-index 0) 'int-value)) 354 350 (n (send (send params :object-at-index 1) 'int-value))) 351 #+debug 355 352 (#_NSLog #@"Note modification: pos = %d, n = %d" :int pos :int n) 356 353 (send self … … 464 461 #'(lambda (tv) 465 462 (send tv :scroll-range-to-visible (send tv 'selected-range))))) 466 467 ;;; This needs to run on the main thread.468 (define-objc-method ((void update-hemlock-selection)469 hemlock-text-storage)470 (let* ((string (send self 'string))471 (buffer (buffer-cache-buffer (hemlock-buffer-string-cache string)))472 (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))473 (point (hi::buffer-point buffer))474 (pos (mark-absolute-position point)))475 #+debug476 (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"477 :int (hi::mark-charpos point) :int pos)478 (for-each-textview-using-storage479 self480 #'(lambda (tv)481 (slet ((selection (ns-make-range pos 0)))482 #+debug483 (#_NSLog #@"Setting selection to %d" :int pos)484 (send tv :set-selected-range selection))))))485 486 463 487 464 … … 512 489 513 490 514 491 ;;; An abstract superclass of the main and echo-area text views. 492 (defclass hemlock-textstorage-text-view (ns::ns-text-view) 493 ((save-blink-color :foreign-type :id)) 494 (:metaclass ns:+ns-object)) 495 496 ;;; Set and display the selection at pos, whose length is len and whose 497 ;;; affinity is affinity. This should never be called from some Cocoa 498 ;;; event handler; it should not call anything that'll try to set the 499 ;;; underlying buffer's point and/or mark. 500 (define-objc-method ((:void :update-selection (:int pos) 501 :length (:int len) 502 :affinity (:<NSS>election<A>ffinity affinity)) 503 hemlock-textstorage-text-view) 504 (slet ((range (ns-make-range pos len))) 505 (send-super :set-selected-range range 506 :affinity affinity 507 :still-selecting nil) 508 (send self :scroll-range-to-visible range))) 509 515 510 ;;; A specialized NSTextView. Some of the instance variables are intended 516 511 ;;; to support paren highlighting by blinking, but that doesn't work yet. 517 512 ;;; The NSTextView is part of the "pane" object that displays buffers. 518 (defclass hemlock-text-view (ns:ns-text-view) 519 ((timer :foreign-type :id :accessor blink-timer) 520 (blink-pos :foreign-type :int :accessor blink-pos) 521 (blink-phase :foreign-type :<BOOL> :accessor blink-phase) 522 (blink-char :foreign-type :int :accessor blink-char) 523 (pane :foreign-type :id :accessor text-view-pane)) 513 (defclass hemlock-text-view (hemlock-textstorage-text-view) 514 ((pane :foreign-type :id :accessor text-view-pane)) 524 515 (:metaclass ns:+ns-object)) 525 516 … … 557 548 ;; Probably not the right place for this, but needs to happen 558 549 ;; -somewhere-, and needs to happen in the event thread. 559 (send self :scroll-range-to-visible (send self 'selected-range))550 560 551 ) 561 552 … … 746 737 (send (text-pane-mode-line pane) :set-needs-display t)) 747 738 739 (def-cocoa-default *text-pane-margin-width* :float 0.0f0 "width of indented margin around text pane") 740 (def-cocoa-default *text-pane-margin-height* :float 0.0f0 "height of indented margin around text pane") 741 742 748 743 (define-objc-method ((:id :init-with-frame (:<NSR>ect frame)) 749 744 text-pane) … … 754 749 #$NSViewHeightSizable)) 755 750 (send pane :set-box-type #$NSBoxPrimary) 756 (send pane :set-border-type #$NSLineBorder) 751 (send pane :set-border-type #$NSNoBorder) 752 (send pane :set-content-view-margins (ns-make-size *text-pane-margin-width* *text-pane-margin-height*)) 757 753 (send pane :set-title-position #$NSNoTitle)) 758 754 pane)) 759 755 760 756 761 (defun make-scrolling-text-view-for-textstorage (textstorage x y width height tracks-width )757 (defun make-scrolling-text-view-for-textstorage (textstorage x y width height tracks-width color) 762 758 (slet ((contentrect (ns-make-rect x y width height))) 763 759 (let* ((scrollview (send (make-objc-instance … … 801 797 (send tv :set-vertically-resizable t) 802 798 (send tv :set-autoresizing-mask #$NSViewWidthSizable) 799 (send tv :set-background-color color) 803 800 (send container :set-width-tracks-text-view tracks-width) 804 801 (send container :set-height-tracks-text-view nil) … … 806 803 (values tv scrollview)))))))) 807 804 808 (defun make-scrolling-textview-for-pane (pane textstorage track-wid ht)805 (defun make-scrolling-textview-for-pane (pane textstorage track-width color) 809 806 (slet ((contentrect (send (send pane 'content-view) 'frame))) 810 807 (multiple-value-bind (tv scrollview) … … 815 812 (pref contentrect :<NSR>ect.size.width) 816 813 (pref contentrect :<NSR>ect.size.height) 817 track-widht) 814 track-width 815 color) 818 816 (send pane :set-content-view scrollview) 819 817 (setf (slot-value pane 'scroll-view) scrollview … … 833 831 834 832 835 (defclass echo-area-view ( ns:ns-text-view)833 (defclass echo-area-view (hemlock-textstorage-text-view) 836 834 () 837 835 (:metaclass ns:+ns-object)) … … 859 857 (defloadvar *hemlock-frame-count* 0) 860 858 861 (defun make-echo-area (hemlock-frame x y width height gap-context )859 (defun make-echo-area (hemlock-frame x y width height gap-context color) 862 860 (slet ((frame (ns-make-rect x y width height)) 863 861 (containersize (ns-make-size 1.0f7 height))) … … 889 887 (send echo :set-vertically-resizable nil) 890 888 (send echo :set-autoresizing-mask #$NSViewWidthSizable) 889 (send echo :set-background-color color) 891 890 (send container :set-width-tracks-text-view nil) 892 891 (send container :set-height-tracks-text-view nil) … … 897 896 echo)))) 898 897 899 (defun make-echo-area-for-window (w gap-context-for-echo-area-buffer )898 (defun make-echo-area-for-window (w gap-context-for-echo-area-buffer color) 900 899 (let* ((content-view (send w 'content-view))) 901 900 (slet ((bounds (send content-view 'bounds))) 902 (let* ((echo-area (make-echo-area w 5.0f0 5.0f0 (- (pref bounds :<NSR>ect.size.width) 24.0f0) 15.0f0 gap-context-for-echo-area-buffer)))901 (let* ((echo-area (make-echo-area w 7.0f0 5.0f0 (- (pref bounds :<NSR>ect.size.width) 29.0f0) 15.0f0 gap-context-for-echo-area-buffer color))) 903 902 (send content-view :add-subview echo-area) 904 903 echo-area)))) … … 913 912 (:metaclass ns:+ns-object)) 914 913 914 (defun double-%-in (string) 915 ;; Replace any % characters in string with %%, to keep them from 916 ;; being treated as printf directives. 917 (let* ((%pos (position #\% string))) 918 (if %pos 919 (concatenate 'string (subseq string 0 %pos) "%%" (double-%-in (subseq string (1+ %pos)))) 920 string))) 921 922 (defun nsstring-for-lisp-condition (cond) 923 (%make-nsstring (double-%-in (princ-to-string cond)))) 924 925 (define-objc-method ((:void :run-error-sheet info) hemlock-frame) 926 (let* ((message (send info :object-at-index 0)) 927 (signal (send info :object-at-index 1))) 928 (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title 929 (if (logbitp 0 (random 2)) 930 #@"Not OK, but what can you do?" 931 #@"The sky is falling. FRED never did this!") 932 (%null-ptr) 933 (%null-ptr) 934 self 935 self 936 (@selector "sheetDidEnd:returnCode:contextInfo:") 937 (@selector "sheetDidDismiss:returnCode:contextInfo:") 938 signal 939 message))) 940 941 (define-objc-method ((:void :sheet-did-end sheet 942 :return-code code 943 :context-info info) 944 hemlock-frame) 945 (declare (ignore sheet code info))) 946 947 (define-objc-method ((:void :sheet-did-dismiss sheet 948 :return-code code 949 :context-info info) 950 hemlock-frame) 951 (declare (ignore sheet code)) 952 (ccl::%signal-semaphore-ptr (%int-to-ptr (send info 'unsigned-int-value)))) 953 954 (defun report-condition-in-hemlock-frame (condition frame) 955 (let* ((semaphore (make-semaphore)) 956 (message (nsstring-for-lisp-condition condition)) 957 (sem-value (make-objc-instance 'ns:ns-number 958 :with-unsigned-int (%ptr-to-int (semaphore.value semaphore))))) 959 (%stack-block ((paramptrs (ash 2 target::word-shift))) 960 (setf (%get-ptr paramptrs 0) message 961 (%get-ptr paramptrs (ash 1 target::word-shift)) sem-value) 962 (let* ((params (make-objc-instance 'ns:ns-array 963 :with-objects paramptrs 964 :count 2))) 965 (send frame 966 :perform-selector-on-main-thread 967 (@selector "runErrorSheet:") 968 :with-object params 969 :wait-until-done t) 970 (wait-on-semaphore semaphore))))) 971 972 (defun hi::report-hemlock-error (condition) 973 (report-condition-in-hemlock-frame condition (send (hi::current-window) 'window))) 974 975 915 976 (defun hemlock-thread-function (q buffer pane echo-buffer echo-window) 916 977 (let* ((hi::*real-editor-input* q) … … 943 1004 (hemlock::new-search-pattern :string-insensitive :forward "Foo")) 944 1005 ) 1006 945 1007 (setf (hi::current-buffer) buffer) 946 947 948 (catch 'editor-top-level-catcher949 950 951 952 953 954 1008 (unwind-protect 1009 (loop 1010 (catch 'hi::editor-top-level-catcher 1011 (handler-bind ((error #'(lambda (condition) 1012 (hi::lisp-error-error-handler condition 1013 :internal)))) 1014 (hi::invoke-hook hemlock::abort-hook) 1015 (hi::%command-loop)))) 1016 (hi::invoke-hook hemlock::exit-hook)))) 955 1017 956 1018 … … 984 1046 985 1047 986 (defun textpane-for-textstorage (ts ncols nrows container-tracks-text-view-width )1048 (defun textpane-for-textstorage (ts ncols nrows container-tracks-text-view-width color) 987 1049 (let* ((pane (nth-value 988 1050 1 989 1051 (new-hemlock-document-window))) 990 (tv (make-scrolling-textview-for-pane pane ts container-tracks-text-view-width )))1052 (tv (make-scrolling-textview-for-pane pane ts container-tracks-text-view-width color))) 991 1053 (multiple-value-bind (height width) 992 1054 (size-of-char-in-font (default-font)) … … 1078 1140 1079 1141 ;;; This function must run in the main event thread. 1080 (defun %hemlock-frame-for-textstorage (ts ncols nrows container-tracks-text-view-width )1081 (let* ((pane (textpane-for-textstorage ts ncols nrows container-tracks-text-view-width ))1142 (defun %hemlock-frame-for-textstorage (ts ncols nrows container-tracks-text-view-width color) 1143 (let* ((pane (textpane-for-textstorage ts ncols nrows container-tracks-text-view-width color)) 1082 1144 (frame (send pane 'window)) 1083 1145 (buffer (text-view-buffer (text-pane-text-view pane)))) 1084 1146 (setf (slot-value frame 'echo-area-view) 1085 (make-echo-area-for-window frame (hi::buffer-gap-context buffer) ))1147 (make-echo-area-for-window frame (hi::buffer-gap-context buffer) color)) 1086 1148 (setf (slot-value frame 'command-thread) 1087 1149 (process-run-function (format nil "Hemlock window thread") … … 1098 1160 1099 1161 1100 (defun hemlock-frame-for-textstorage (ts ncols nrows container-tracks-text-view-width )1162 (defun hemlock-frame-for-textstorage (ts ncols nrows container-tracks-text-view-width color) 1101 1163 (process-interrupt *cocoa-event-process* 1102 1164 #'%hemlock-frame-for-textstorage 1103 ts ncols nrows container-tracks-text-view-width)) 1104 1105 1106 1107 1165 ts ncols nrows container-tracks-text-view-width color)) 1166 1167 1168 1169 (defun hi::lock-buffer (b) 1170 (grab-lock (hi::buffer-gap-context-lock (hi::buffer-gap-context b)))) 1171 1172 (defun hi::unlock-buffer (b) 1173 (release-lock (hi::buffer-gap-context-lock (hi::buffer-gap-context b)))) 1108 1174 1109 1175 (defun hi::document-begin-editing (document) … … 1124 1190 1125 1191 (defun hi::document-set-point-position (document) 1192 (declare (ignorable document)) 1126 1193 #+debug 1127 1194 (#_NSLog #@"Document set point position called") … … 1146 1213 (%get-ptr paramptrs (ash 1 target::word-shift)) 1147 1214 number-for-n) 1148 (let* ((params ( send (send (@class "NSArray") "alloc")1149 :init-with-objects paramptrs1150 :count 2)))1215 (let* ((params (make-objc-instance 'ns:ns-array 1216 :with-objects paramptrs 1217 :count 2))) 1151 1218 (send textstorage 1152 1219 :perform-selector-on-main-thread … … 1197 1264 (textstorage (if document (slot-value document 'textstorage)))) 1198 1265 (when textstorage 1266 #+debug 1199 1267 (#_NSLog #@"enqueue modify: pos = %d, n = %d" 1200 1268 :int (mark-absolute-position mark) … … 1280 1348 ((textstorage :foreign-type :id)) 1281 1349 (:metaclass ns:+ns-object)) 1350 1351 (defmethod textview-background-color ((doc hemlock-editor-document)) 1352 (send (find-class 'ns:ns-color) 1353 :color-with-calibrated-red *editor-background-red-component* 1354 :green *editor-background-green-component* 1355 :blue *editor-background-blue-component* 1356 :alpha *editor-background-alpha-component*)) 1357 1282 1358 1283 1359 (define-objc-method ((:id init) hemlock-editor-document) … … 1376 1452 *editor-columns* 1377 1453 *editor-rows* 1378 nil)))) 1454 nil 1455 (textview-background-color self))))) 1379 1456 (send self :add-window-controller controller) 1380 1457 (send controller 'release))) … … 1400 1477 (send textview :page-up nil))))) 1401 1478 1479 ;;; This needs to run on the main thread. 1480 (define-objc-method ((void update-hemlock-selection) 1481 hemlock-text-storage) 1482 (let* ((string (send self 'string)) 1483 (buffer (buffer-cache-buffer (hemlock-buffer-string-cache string))) 1484 (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) 1485 (point (hi::buffer-point buffer)) 1486 (pos (mark-absolute-position point)) 1487 (len 0)) 1488 #+debug 1489 (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d" 1490 :int (hi::mark-charpos point) :int pos) 1491 (for-each-textview-using-storage 1492 self 1493 #'(lambda (tv) 1494 (send tv 1495 :update-selection pos 1496 :length len 1497 :affinity #$NSSelectionAffinityUpstream))))) 1498 1402 1499 1403 1500 (defun hi::allocate-temporary-object-pool ()
Note:
See TracChangeset
for help on using the changeset viewer.
