Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv12696
Modified Files: beirc.lisp Log Message: The multi-channel ("receiver") hack.
This patch comes with a lot of problems. But it's just way too cool to just leave it out. (-:
problems:
* on join (you or anybody else), you are thrown into the debugger, with a message about a bounding-rectangle method that's not applicable to (NIL). Not investigated yet.
* every time anybody (including you) sends a PRIVMSG, the interactor pane is wiped. This is related to the frame-redisplay-panes call in the (handle-event frame foo-event) method.
* Every IRC message that isn't a JOIN, QUIT or PRIVMSG will land you in the terminal debugger. feel free to implement more receiver-for-message methods.
Date: Tue Sep 13 22:48:12 2005 Author: afuchs
Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.1.1.1 beirc/beirc.lisp:1.2 --- beirc/beirc.lisp:1.1.1.1 Mon Sep 12 20:13:09 2005 +++ beirc/beirc.lisp Tue Sep 13 22:48:11 2005 @@ -28,6 +28,11 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;;
+(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:require :split-sequence) + (cl:require :cl-irc) + (cl:require :mcclim)) + (defpackage :beirc (:use :clim :clim-lisp :clim-sys) (:export #:beirc)) @@ -60,21 +65,130 @@ ;; <mumble> is just the rest of the input line. ;; <nickname> is a nickname of someone, with completion
+(defclass receiver () + ((name :reader receiver-name :initarg :name) + (messages :accessor messages :initform nil) + (channel :reader channel :initform nil :initarg :channel) + (query :reader query :initform nil :initarg :query) ;; <- XXX: remove this. + (pane :reader pane :initform nil) + (focused-nicks :accessor focused-nicks :initform nil))) + +(defmethod initialize-instance :after ((object receiver) &rest initargs) + (declare (ignore initargs)) + (setf (slot-value object 'pane) + (with-look-and-feel-realization + ((frame-manager *application-frame*) *application-frame*) + (print (make-clim-application-pane + :display-function + (lambda (frame pane) + (beirc-app-display frame pane object)) + :display-time :command-loop + :width 400 :height 600 + :incremental-redisplay t) *debug-io*)))) + +(defun make-receiver (name &rest initargs) + (let ((receiver (apply 'make-instance 'receiver :name name initargs))) + (setf (gethash name (receivers *application-frame*)) + receiver) + (setf (gethash (pane receiver) (receiver-panes *application-frame*)) + receiver) + receiver)) + +(defun intern-receiver (name frame &rest initargs) + (let ((rec (gethash name (receivers frame)))) + (if rec + rec + (let ((*application-frame* frame)) + (apply 'make-receiver name initargs))))) + +(defun receiver-for-pane (pane &optional (frame *application-frame*)) + (gethash pane (receiver-panes frame))) + + +(defmethod receiver-for-message ((message irc:irc-privmsg-message) frame) + ;; XXX: handle target=ournick + (let ((target (first (irc:arguments message)))) + (intern-receiver target frame :channel target))) + +(defmethod receiver-for-message ((message irc:irc-join-message) frame) + (let ((target (first (irc:arguments message)))) + (intern-receiver target frame :channel target))) + +(defmethod receiver-for-message ((message irc:irc-quit-message) frame) + (current-receiver frame) ; FIXME: quit messages should go to all channels/queries the user was on. + ) + +;; TODO: more receiver-for-message methods. + +(macrolet ((define-delegate (function-name accessor &optional define-setter-p) + `(progn + ,(when define-setter-p + `(defun (setf ,function-name) (new-value &optional (frame *application-frame*)) + (when (current-receiver frame) + (setf (,accessor (current-receiver frame)) new-value)))) + (defun ,function-name (&optional (frame *application-frame*)) + (when (current-receiver frame) + (,accessor (current-receiver frame))))))) + (define-delegate current-channel channel) + (define-delegate current-query query) + (define-delegate current-pane pane) + (define-delegate current-messages messages t) + (define-delegate current-focused-nicks focused-nicks t)) + + + +(defclass stack-layout-pane (clim:sheet-multiple-child-mixin + clim:basic-pane) + ()) + +(defmethod compose-space ((pane stack-layout-pane) &key width height) + (declare (ignore width height)) + (reduce (lambda (x y) + (space-requirement-combine #'max x y)) + (mapcar #'compose-space (sheet-children pane)) + :initial-value + (make-space-requirement :width 0 :min-width 0 :max-width 0 + :height 0 :min-height 0 :max-height 0))) + +(defmethod allocate-space ((pane stack-layout-pane) width height) + (dolist (child (sheet-children pane)) + (move-and-resize-sheet child 0 0 width height) + (allocate-space child width height))) + +(defmethod initialize-instance :after ((pane stack-layout-pane) + &rest args + &key initial-contents + &allow-other-keys) + (declare (ignore args)) + (dolist (k initial-contents) + (sheet-adopt-child pane k))) + +(defun raise-receiver (receiver &optional (frame *application-frame*)) + (setf (current-receiver frame) receiver) + (mapcar (lambda (pane) + (let ((pane-receiver (receiver-for-pane pane frame))) + (setf (sheet-enabled-p pane) + (eql receiver pane-receiver)))) + (sheet-children (find-pane-named frame 'query)))) + (define-application-frame beirc () - ((connection :initform nil) - (messages :initform nil) - (query :initform nil) + ((current-receiver :initform nil :accessor current-receiver) + (connection :initform nil) (nick :initform nil) - (channel :initform nil) - (focused-nicks :initform nil) - (ignored-nicks :initform nil)) + (ignored-nicks :initform nil) + (receivers :initform (make-hash-table :test 'equal) :reader receivers) + (receiver-panes :initform (make-hash-table :test 'eql) :reader receiver-panes)) (:panes - (app :application - :display-function 'beirc-app-display - :display-time :command-loop - :incremental-redisplay t) (io :interactor) + (query (make-pane 'stack-layout-pane)) + (receiver-bar + :application + :display-function 'beirc-receivers-display + :display-time :command-loop + :incremental-redisplay t + :height 20 + :scroll-bars nil) (status-bar :application :display-function 'beirc-status-display @@ -90,8 +204,10 @@ (:layouts (default (vertically () - app + query (60 io) + (20 + receiver-bar) (20 ;<-- Sigh! Bitrot! status-bar )))))
@@ -99,6 +215,14 @@
(defvar *beirc-frame*)
+(defun beirc-receivers-display (*application-frame* *standard-output*) + (with-text-family (t :sans-serif) + (maphash (lambda (key value) + (declare (ignore key)) + (present value 'receiver :stream *standard-output*) + (format t " ")) + (receivers *application-frame*)))) + (defun beirc-status-display (*application-frame* *standard-output*) (with-text-family (t :sans-serif) (multiple-value-bind (seconds minutes hours) (decode-universal-time (get-universal-time)) @@ -106,14 +230,14 @@ (format t "~2,'0D:~2,'0D ~A on ~A~@[ speaking to ~A~]~100T~D messages" hours minutes (slot-value *application-frame* 'nick) - (slot-value *application-frame* 'channel) - (slot-value *application-frame* 'query) - (length (slot-value *application-frame* 'messages)))))) + (current-channel) + (current-query) + (length (current-messages))))))
(defun beirc-prompt (*standard-output* *application-frame*) (format *standard-output* "Beirc ~A => " - (or (slot-value *application-frame* 'query) - (slot-value *application-frame* 'channel)))) + (or (current-query) + (current-channel))))
;; (defun format-message (prefix mumble) ;; (write-line @@ -131,14 +255,14 @@ (cond (start (write-string (subseq url 0 start)) (present (concatenate 'string - "file://localhost/path/to/your/HyperSpec/" + "file://localhost/Users/dmurray/lisp/HyperSpec/" (subseq url (+ 45 start))) 'url)) (t (present url 'url)))))
(defun format-message* (preamble mumble &key (prefix " ") - (limit 105)) + (limit 100)) (loop for word in (split-sequence:split-sequence #\Space mumble) with line-prefix = prefix with column = (+ (length line-prefix) (length preamble)) @@ -161,7 +285,7 @@ (define-presentation-type url () :inherit-from 'string)
-(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE)) +(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) (with-drawing-options (*standard-output* :ink (if (string-equal "localhost" (irc:host message)) @@ -171,7 +295,7 @@ :test #'string=) (with-text-face (*standard-output* - (if (member (irc:source message) (slot-value *application-frame* 'focused-nicks) + (if (member (irc:source message) (current-focused-nicks) :test #'string=) :bold :roman)) @@ -189,7 +313,7 @@ (format nil "*~A*" (irc:source message))))))) (format-message* preamble (irc:trailing-argument message)))))))
-(defmethod print-message ((message irc:ctcp-action-message)) +(defmethod print-message ((message irc:ctcp-action-message) receiver) (let ((source (cl-irc:source message)) (matter (trailing-argument* message)) (dest (car (cl-irc:arguments message)))) @@ -198,19 +322,18 @@ source) matter)))
-(defmethod print-message ((message irc:irc-quit-message)) +(defmethod print-message ((message irc:irc-quit-message) receiver) (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format-message* (format nil "~10T Quit: ~A;" (irc:source message)) (irc:trailing-argument message))))
-(defmethod print-message ((message irc:irc-join-message)) +(defmethod print-message ((message irc:irc-join-message) receiver) (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format *standard-output* "~10T Join: ~A (~A@~A)" (irc:source message) (irc:user message) - (irc:host message) - (irc:trailing-argument message)) + (irc:host message)) (terpri) ))
;;; Here comes the trick: @@ -222,7 +345,8 @@ ;;; we send it to the frame.
(defclass foo-event (clim:window-manager-event) - ((sheet :initarg :sheet :reader event-sheet))) + ((sheet :initarg :sheet :reader event-sheet) + (receiver :initarg :receiver :reader receiver)))
;;for updating the time display, triggered from TICKER (defclass bar-event (clim:window-manager-event) @@ -244,11 +368,14 @@ (defmethod handle-event ((frame beirc) (event foo-event)) ;; Hack: ;; Figure out if we are scrolled to the bottom. - (let ((pane (get-frame-pane frame 'app))) + (let* ((receiver (receiver event)) + (pane (pane receiver))) ; FIXME: pane isn't a stream pane, but a VRACK-PANE. gack. (let ((btmp (pane-scrolled-to-bottom-p pane))) - (time (redisplay-frame-pane frame pane)) - (when btmp - (scroll-pane-to-bottom pane))) + (setf (pane-needs-redisplay pane) t) + (time (redisplay-frame-panes frame :force-p t)) +;; (when btmp +;; (scroll-pane-to-bottom pane)) + ) (medium-force-output (sheet-medium pane)) ;### ))
@@ -273,12 +400,13 @@ (run-frame-top-level frame))))))))
(defun post-message (frame message) - (setf (slot-value frame 'messages) - (append (slot-value frame 'messages) (list message))) - (clim-internals::event-queue-prepend - (climi::frame-event-queue frame) - (make-instance 'foo-event :sheet frame)) - nil) + (let ((receiver (receiver-for-message message frame))) + (setf (messages receiver) + (append (messages receiver) (list message))) + (clim-internals::event-queue-prepend + (climi::frame-event-queue frame) + (make-instance 'foo-event :sheet frame :receiver receiver)) + nil))
(defun ticker (frame) (loop @@ -293,13 +421,30 @@ res)
(define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key) - (with-slots (connection nick channel) *application-frame* - (let ((users (mapcar #'car (hash-alist (irc:users (irc:find-channel connection channel)))))) + (with-slots (connection nick) *application-frame* + (let ((users (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel))))))) (accept `(member ,@users) :prompt nil))))
+(define-presentation-method accept ((type receiver) *standard-input* (view textual-view) &key) + (completing-from-suggestions (*standard-input* :partial-completers '(#\Space)) + (maphash #'suggest (receivers *application-frame*)))) + +(define-presentation-method present (o (type receiver) *standard-output* (view textual-view) &key) + (format t "~A" (receiver-name o))) + +(define-presentation-to-command-translator raise-this-receiver + (receiver com-raise-receiver beirc + :gesture :select + :documentation "Raise this receiver") + (presentation) + (list (presentation-object presentation))) + +(define-beirc-command (com-raise-receiver :name t) ((receiver 'receiver :prompt "Receiver")) + (raise-receiver receiver)) + (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who")) - (pushnew who (slot-value *application-frame* 'focused-nicks) :test #'string=)) + (pushnew who (current-focused-nicks) :test #'string=))
(define-beirc-command (com-ignore :name t) ((who 'nickname :prompt "who")) (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=)) @@ -309,12 +454,12 @@ (remove who (slot-value *application-frame* 'ignored-nicks) :test #'string=)))
(define-beirc-command (com-unfocus :name t) ((who 'nickname :prompt "who")) - (setf (slot-value *application-frame* 'focused-nicks) - (remove who (slot-value *application-frame* 'focused-nicks) :test #'string=))) + (setf (current-focused-nicks) + (remove who (current-focused-nicks) :test #'string=)))
(defun target (&optional (*application-frame* *application-frame*)) - (or (slot-value *application-frame* 'query) - (slot-value *application-frame* 'channel))) + (or (current-query) + (current-channel)))
(define-beirc-command (com-say :name t) ((what 'mumble)) ;; make a fake IRC-PRIV-MESSAGE object @@ -347,11 +492,11 @@ (list (presentation-object presentation)))
(define-beirc-command (com-join :name t) ((channel 'string :prompt "channel")) - (when (slot-value *application-frame* 'channel) - (irc:part - (slot-value *application-frame* 'connection) - (slot-value *application-frame* 'channel))) - (setf (slot-value *application-frame* 'channel) channel) + (setf (current-receiver *application-frame*) + (intern-receiver channel *application-frame* :channel channel)) + (sheet-adopt-child (find-pane-named *application-frame* 'query) + (pane (current-receiver *application-frame*))) + (raise-receiver (current-receiver *application-frame*)) (irc:join (slot-value *application-frame* 'connection) channel))
(define-beirc-command (com-connect :name t) @@ -381,12 +526,12 @@ (window-clear stream)))
(defun restart-beirc () - (let ((m (slot-value *beirc-frame* 'messages))) + (let ((m (current-messages))) (clim-sys:destroy-process *gui-process*) (setf *beirc-frame* nil) (beirc) (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*)) - (setf (slot-value *beirc-frame* 'messages) m))) + (setf (current-messages) m)))
;;;;;;;;; @@ -436,36 +581,37 @@ (irc:read-message-loop connection) ) (irc:remove-all-hooks connection)))
-(defun beirc-app-display (*application-frame* *standard-output*) +(defun beirc-app-display (*application-frame* *standard-output* receiver) ;; Fix me: This usage of UPDATING-OUTPUT is sub-optimal and ugly! + ;; Fix me: as is all that *standard-output* stuff + (print *standard-output* *debug-io*) + (print (pane receiver) *debug-io*) (let ((w (- (floor (bounding-rectangle-width (sheet-parent *standard-output*)) (clim:stream-string-width *standard-output* "X")) - 2))) - (with-slots (messages) *application-frame* - (let ((k 100) - (n (length messages))) - (loop for i below (* k (ceiling n k)) by k do + 2)) + (messages (and receiver (messages receiver)))) + (let ((k 100) + (n (length messages))) + (loop for i below (* k (ceiling n k)) by k do + (updating-output (*standard-output* + :unique-id i + :cache-value + (list (min n (+ i k)) + (focused-nicks receiver) + (slot-value *application-frame* 'ignored-nicks) + w) + :cache-test #'equal) + (loop for j from i below (min n (+ i k)) do + (let ((m (elt messages j))) (updating-output (*standard-output* - :unique-id i + :unique-id j :cache-value - (list (min n (+ i k)) - (slot-value *application-frame* 'focused-nicks) - (slot-value *application-frame* 'ignored-nicks) - w) - :cache-test #'equal - ) - (loop for j from i below (min n (+ i k)) do - (let ((m (elt messages j))) - (updating-output (*standard-output* - :unique-id j - :cache-value - (list m - (slot-value *application-frame* 'focused-nicks) - (slot-value *application-frame* 'ignored-nicks) - w) - :cache-test #'equal - ) - (print-message m)))))))))) + (list m + (focused-nicks receiver) + (slot-value *application-frame* 'ignored-nicks) + w) + :cache-test #'equal) + (print-message m receiver))))))))) ;;; Hack:
(defmethod allocate-space :after ((pane climi::viewport-pane) w h)