Changeset 6788

Timestamp:

Jul 6, 2007, 12:00:19 PM (17 years ago)

Author:

Gary Byers

Message:

Move towards multiple typeout panels.

File:

• branches/ide-1.0/ccl/examples/cocoa-typeout.lisp (modified) (5 diffs)

branches/ide-1.0/ccl/examples/cocoa-typeout.lisp

@@ -5 +5 @@
 
 ;;
-;; the typeout panel is just an ns-panel containing a scroll-view
+;; a typeout window is just an ns-window containing a scroll-view
 ;; which contains a text-view. The text is read only.
 ;;
-;; There is only one panel which is created with the first invocation
-;; of the 'shared-panel class method. The panel is bound to the 
-;; variable ccl::*typeout-panel*
-;;
-;; the panel is implicitly bound to a stream, and text written to
+;; the window is implicitly bound to a stream, and text written to
 ;; the stream is written into the text-view object. The stream is 
 ;; available via the function (ccl::typeout-stream)
 ;;
-;; the panel width is set to 600 pixels, which is fine since hemlock
-;; looks like it wants to wrap the documentation at 80 characters
-;; anyway. In the long run this window should use a variable size font
-;; and maybe compute the width as 80 times the width of the letter W.
-;;
-;; I'll revisit this after the preferences are more defined.
-;;
+
 ;; @class typeout-view
 ;;
 (defclass typeout-view (ns:ns-view)
   ((scroll-view :foreign-type :id :reader typeout-view-scroll-view)
-   (text-view :foreign-type :id :reader typeout-view-text-view)
-   (text-storage :foreign-type :id :reader typeout-view-text-storage))
+   (text-view :foreign-type :id :reader typeout-view-text-view))
   (:metaclass ns:+ns-object))
+
+(defclass typeout-text-view (ns:ns-text-view)
+    ()
+  (:metaclass ns:+ns-object))
+
+(objc:defmethod (#/clearAll: :void) ((self typeout-text-view))
+  (#/selectAll: self +null-ptr+)
+  (#/delete: self +null-ptr+))
+
+(objc:defmethod (#/insertText: :void) ((self typeout-text-view) text)
+  (#/setEditable: self t)
+  (call-next-method text)
+  (#/setEditable: self nil))
+
 
 (objc:defmethod #/initWithFrame: ((self typeout-view) (frame :<NSR>ect))
@@ -38 +41 @@
     (#/setBorderType: scrollview #$NSBezelBorder)
     (#/setHasVerticalScroller: scrollview t)
-    (#/setHasHorizontalScroller: scrollview nil)
+    (#/setHasHorizontalScroller: scrollview t)
     (#/setRulersVisible: scrollview nil)
-    (#/setAutoresizingMask: scrollview #$NSViewHeightSizable)
+    (#/setAutoresizingMask: scrollview (logior #$NSViewWidthSizable #$NSViewHeightSizable))
     (#/setAutoresizesSubviews: scroll-content t)
     (#/addSubview: self scrollview)
@@ -46 +49 @@
     (let* ((contentsize (#/contentSize scrollview)))
       (ns:with-ns-rect (text-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize))
-        (let* ((text-view (make-instance 'ns:ns-text-view
-                                         :with-frame text-frame))
-               (text-storage (#/textStorage text-view)))
+        (let* ((text-view (make-instance 'typeout-text-view
+                                         :with-frame text-frame)))
           (#/setEditable: text-view nil)
-          (setf (slot-value self 'text-storage) text-storage)
+          (#/setHorizontallyResizable: text-view t)
+          (#/setAutoresizingMask: text-view #$NSViewWidthSizable)
+          (#/setTypingAttributes: text-view (create-text-attributes 
+                                  :font (default-font :name *default-font-name* :size *default-font-size*)
+                                  :line-break-mode :char))
           (#/setDocumentView: scrollview text-view)
+          (ns:with-ns-size (container-size 1.0f7 1.0f7)
+          (let* ((layout (#/layoutManager text-view))
+                 (container (make-instance 'ns:ns-text-container
+                                           :with-container-size container-size)))
+            (#/setWidthTracksTextView: container t)
+            (#/setHeightTracksTextView: container nil)
+            (#/addTextContainer: layout container)))
+        
           (setf (slot-value self 'text-view) text-view)))))
   self)
@@ -58 +72 @@
 ;; @class typeout-panel
 ;;
-(defloadvar *typeout-panel* nil)
+(defloadvar *typeout-window* nil)
 
-(defclass typeout-panel (ns:ns-panel)
-    ((typeout-view :foreign-type :id :accessor typeout-panel-typeout-view))
+(defclass typeout-window (ns:ns-window)
+    ((typeout-view :foreign-type :id :accessor typeout-window-typeout-view))
   (:metaclass ns:+ns-object))
 
-(objc:defmethod #/sharedPanel ((self +typeout-panel))
-   (cond (*typeout-panel*)
+(defloadvar *typeout-windows* ())
+(defstatic *typeout-windows-lock* (make-lock))
+
+(defun get-typeout-window (title)
+  (with-lock-grabbed (*typeout-windows-lock*)
+    (when *typeout-windows*
+      (let* ((w (pop *typeout-windows*)))
+        (set-window-title w title)
+        w))))
+
+(objc:defmethod #/typeoutWindowWithTitle: ((self +typeout-window) title)
+  (let* ((panel (new-cocoa-window :class self
+                                  :title title
+                                  :width 600
+                                  :activate nil)))
+    (#/setReleasedWhenClosed: panel nil)
+    (let* ((view (make-instance 'typeout-view :with-frame (#/bounds (#/contentView panel)))))
+      (#/setAutoresizingMask: view (logior
+                                    #$NSViewWidthSizable
+                                    #$NSViewHeightSizable))
+      (#/setContentView: panel view)
+      (#/setNeedsDisplay: view t)
+      (setf (slot-value panel 'typeout-view) view)
+      panel)))
+
+(objc:defmethod #/sharedPanel ((self +typeout-window))
+   (cond (*typeout-window*)
          (t
-          (let* ((panel (new-cocoa-window :class self
-                                          :title "Typeout"
-                                          :width 600
-                                          :activate nil)))
-            (ns:with-ns-size (size 600 10000)
-                             (#/setMaxSize: panel size)
-                             (setf (ns:ns-size-height size) 1)
-                             (#/setMinSize: panel size))
-            (let* ((view (make-instance 'typeout-view :with-frame (#/bounds (#/contentView panel)))))
-              (#/setContentView: panel view)
-              (#/setNeedsDisplay: view t)
-              (setf (slot-value panel 'typeout-view) view)
-              (setq *typeout-panel* panel))))))
-
-(objc:defmethod #/init ((self typeout-panel))
-  (let* ((class (class-of self)))
-    (#/dealloc self)
-    (#/sharedPanel class)))
+          (setq *typeout-window* (#/typeoutWindowWithTitle: self "Typeout")))))
 
 
-(objc:defmethod (#/show :void) ((self typeout-panel))
-  (#/orderFront: self +null-ptr+))
 
-(defloadvar *typeout-attributes* nil)
+(objc:defmethod (#/close :void) ((self typeout-window))
+  (call-next-method)
+  (unless (eql self *typeout-window*)
+    (with-lock-grabbed (*typeout-windows-lock*)
+      (push (%inc-ptr self 0) *typeout-windows*))))
+
+
+
+(objc:defmethod (#/show :void) ((self typeout-window))
+  (#/makeKeyAndOrderFront: self +null-ptr+))
+
 
 (defclass typeout-stream (fundamental-character-output-stream)
-  ((text-storage :initform nil :accessor typeout-stream-text-storage)
-   (line-number :initform 0 :accessor typeout-stream-line-number)
-   (line-position :initform 0 :accessor typeout-stream-line-position)))
+  ((string-stream :initform (make-string-output-stream))
+   (window :initform (#/sharedPanel typeout-window) :initarg :window)))
 
 (defun prepare-typeout-stream (stream)
-  (let ((panel (#/sharedPanel typeout-panel)))
-    (unless (typeout-stream-text-storage stream)
-      (setf (typeout-stream-text-storage stream) (typeout-view-text-storage (typeout-panel-typeout-view panel))))
-    (unless *typeout-attributes*
-      (setf *typeout-attributes* (create-text-attributes 
-                                  :font (default-font :name *default-font-name* :size *default-font-size*)
-                                  :line-break-mode :word)))
-    (#/show panel)))
+  (declare (ignorable stream))
+  (with-slots (window) stream
+    (#/show window)))
 
 
@@ -115 +139 @@
 (defmethod stream-write-char ((stream typeout-stream) char)
   (prepare-typeout-stream stream)
-  ;;
-  ;;  convert tabs to spaces.
-  ;;
-  (if (eq char #\tab)
-      (return-from stream-write-char
-        (progn
-          (format stream "(make-string (- 8 (mod ~A 8)) :initial-element #\space)~%" (typeout-stream-line-position stream))
-          (stream-write-string stream (make-string (- 8 (mod (typeout-stream-line-position stream) 8))
-                                                   :initial-element #\space)))))
-
-  ;;
-  ;;  Maybe convert non-printable characters to something else?
-  ;;  This is a problem for the editor, but probably not here.
-
-  ;;
-  ;;  adjust the line and column #s accordingly
-  ;;
-  (if (eq char #\newline)
-      (progn
-        (incf (typeout-stream-line-number stream))
-        (setf (typeout-stream-line-position stream) 0))
-    (incf (typeout-stream-line-position stream)))
-
-  ;;
-  ;;  print the character by converting it to a string and appending
-  ;;  it to the text-storage buffer.
-  ;;
-  (let* ((the-typeout-view (typeout-panel-typeout-view *typeout-panel*))
-         (text-storage (slot-value the-typeout-view 'text-storage))
-         (str (make-string 1 :initial-element char))
-         (attr-str (make-instance 'ns:ns-attributed-string 
-                                  :with-string str
-                                  :attributes *typeout-attributes*)))
-    (#/appendAttributedString: text-storage attr-str)))
+  (write-char char (slot-value stream 'string-stream)))
 
 (defmethod stream-write-string ((stream typeout-stream) string &optional (start 0) end)
   (prepare-typeout-stream stream)
-  (let* ((str (if start 
-                  (subseq string start end)
-                string))
-         (attr-str (make-instance 'ns:ns-attributed-string 
-                                  :with-string str
-                                  :attributes *typeout-attributes*))
-         (the-typeout-view (typeout-panel-typeout-view *typeout-panel*))
-         (text-storage (slot-value the-typeout-view 'text-storage)))
-    (setf (typeout-stream-line-position stream) (length string))
-    (#/appendAttributedString: text-storage attr-str)))
+  (write-string (if (and (eql start 0) (or (null end) (eql end (length string))))
+                    string 
+                    (subseq string start end))
+                (slot-value stream 'string-stream)))
 
+  
 (defmethod stream-fresh-line ((stream typeout-stream))
   (prepare-typeout-stream stream)
-  (stream-write-char stream #\newline))
+  (fresh-line (slot-value stream 'string-stream)))
 
 (defmethod stream-line-column ((stream typeout-stream))
-  (typeout-stream-line-position stream))
+  (stream-line-column (slot-value stream 'string-stream)))
 
 (defmethod stream-clear-output ((stream typeout-stream))
   (prepare-typeout-stream stream)
-  (let* ((the-typeout-view (typeout-panel-typeout-view *typeout-panel*))
-         (text-storage (slot-value the-typeout-view 'text-storage))
-         (len (#/length text-storage)))
-    (declare (type ns:ns-text-storage text-storage))
+  (let* ((window (slot-value stream 'window))
+         (the-typeout-view (typeout-window-typeout-view window))
+         (text-view (slot-value the-typeout-view 'text-view))
+         (string-stream (slot-value stream 'string-stream)))
+    (get-output-stream-string string-stream)
     (#/performSelectorOnMainThread:withObject:waitUntilDone:
-     text-storage
-     (@selector #/beginEditing)
+     text-view
+     (@selector #/clearAll:)
      +null-ptr+
-     t)
-    (#/deleteCharactersInRange: text-storage (ns:make-ns-range 0 len))))
+     t)))
 
 (defmethod stream-force-output ((stream typeout-stream))
-  (let* ((the-typeout-view (typeout-panel-typeout-view *typeout-panel*))
-         (text-storage (slot-value the-typeout-view 'text-storage)))
+  (let* ((window (slot-value stream 'window))
+         (the-typeout-view (typeout-window-typeout-view window))
+         (text-view (slot-value the-typeout-view 'text-view)))
     (#/performSelectorOnMainThread:withObject:waitUntilDone:
-     text-storage
-     (@selector #/endEditing)
-     +null-ptr+
+     text-view
+     (@selector #/insertText:)
+     (%make-nsstring (get-output-stream-string (slot-value stream 'string-stream))) 
      t)))
   
 
+(defloadvar *typeout-stream* nil)
 
-(defloadvar *typeout-stream* (make-instance 'typeout-stream))
+(defun typeout-stream (&optional title)
+  (if (null title)
+    (or *typeout-stream*
+        (setq *typeout-stream* (make-instance 'typeout-stream)))
+    (make-instance 'typeout-stream :window (#/typeoutWindowWithTitle: typeout-window (%make-nsstring (format nil "~a" title))))))
 
-(defun typeout-stream ()
-  *typeout-stream*)
-