Author: ksprotte Date: Mon Feb 18 05:46:33 2008 New Revision: 2533
Added: branches/trunk-reorg/thirdparty/arnesi/src/slime-extras.lisp Modified: branches/trunk-reorg/thirdparty/arnesi/arnesi.asd branches/trunk-reorg/thirdparty/arnesi/src/log.lisp branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp Log: pulled latest arnesi - no slime dep anymore
Modified: branches/trunk-reorg/thirdparty/arnesi/arnesi.asd ============================================================================== --- branches/trunk-reorg/thirdparty/arnesi/arnesi.asd (original) +++ branches/trunk-reorg/thirdparty/arnesi/arnesi.asd Mon Feb 18 05:46:33 2008 @@ -35,7 +35,7 @@ (:file "lisp1" :depends-on ("packages" "lambda-list" "one-liners" "walk" "unwalk")) (:file "lexenv" :depends-on ("packages" "one-liners")) (:file "list" :depends-on ("packages" "one-liners" "accumulation" "flow-control")) - ;; (:file "log" :depends-on ("packages" "numbers" "hash" "io")) + (:file "log" :depends-on ("packages" "numbers" "hash" "io")) (:file "matcher" :depends-on ("packages" "hash" "list" "flow-control" "one-liners")) (:file "mop" :depends-on ("packages" "mopp")) (:file "mopp" :depends-on ("packages" "list" "flow-control")) @@ -55,15 +55,14 @@ (:file "vector" :depends-on ("packages" "flow-control")) (:file "walk" :depends-on ("packages" "list" "mopp" "lexenv" "one-liners"))))) :properties ((:features "v1.4.0" "v1.4.1" "v1.4.2" "cc-interpreter" - "join-strings-return-value" "getenv")) - :depends-on (:swank)) + "join-strings-return-value" "getenv")))
(defsystem :arnesi.test :components ((:module :t :components ((:file "accumulation" :depends-on ("suite")) (:file "call-cc" :depends-on ("suite")) (:file "http" :depends-on ("suite")) - ;; (:file "log" :depends-on ("suite")) + (:file "log" :depends-on ("suite")) (:file "matcher" :depends-on ("suite")) (:file "numbers" :depends-on ("suite")) (:file "queue" :depends-on ("suite")) @@ -83,6 +82,10 @@ :components ((:file "cl-ppcre-extras")))) :depends-on (:cl-ppcre :arnesi))
+(defsystem :arnesi.slime-extras + :components ((:module :src :components ((:file "slime-extras")))) + :depends-on (:arnesi :swank)) + (defmethod perform ((op asdf:test-op) (system (eql (find-system :arnesi)))) (asdf:oos 'asdf:load-op :arnesi.test) (funcall (intern (string :run!) (string :it.bese.FiveAM))
Modified: branches/trunk-reorg/thirdparty/arnesi/src/log.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/arnesi/src/log.lisp (original) +++ branches/trunk-reorg/thirdparty/arnesi/src/log.lisp Mon Feb 18 05:46:33 2008 @@ -77,45 +77,6 @@ (pushnew l (children anc) :test (lambda (a b) (eql (name a) (name b))))))
-(defun log-level-setter-inspector-action-for (prompt current-level setter) - (lambda () - (with-simple-restart - (abort "Abort setting log level") - (let ((value-string (swank::eval-in-emacs - `(condition-case c - (let ((arnesi-log-levels '(,@(mapcar #'string-downcase (coerce *log-level-names* 'list))))) - (slime-read-object ,prompt :history (cons 'arnesi-log-levels ,(1+ current-level)) - :initial-value ,(string-downcase (log-level-name-of current-level)))) - (quit nil))))) - (when (and value-string - (not (string= value-string ""))) - (funcall setter (eval (let ((*package* #.(find-package :arnesi))) - (read-from-string value-string))))))))) - -(defmethod swank:inspect-for-emacs ((category log-category)) - (let ((class (class-of category))) - (values "A log-category." - `("Class: " (:value ,class) (:newline) - "Runtime level: " (:value ,(log.level category) - ,(string (log-level-name-of (log.level category)))) - " " - (:action "[set level]" ,(log-level-setter-inspector-action-for - "Set runtime log level to (evaluated): " - (log.level category) - (lambda (value) - (setf (log.level category) value)))) - (:newline) - "Compile-time level: " (:value ,(log.compile-time-level category) - ,(string (log-level-name-of (log.compile-time-level category)))) - " " - (:action "[set level]" ,(log-level-setter-inspector-action-for - "Set compile-time log level to (evaluated): " - (log.compile-time-level category) - (lambda (value) - (setf (log.compile-time-level category) value)))) - (:newline) - ,@(swank::all-slots-for-inspector category))))) - ;;; Runtime levels (defmethod enabled-p ((cat log-category) level) (>= level (log.level cat))) @@ -331,69 +292,6 @@ :verbosity verbosity args))
-(defclass slime-repl-log-appender (appender) - () - (:documentation "Logs to the slime repl when there's a valid swank::*emacs-connection* bound. Arguments are presented ready for inspection. - -You may want to add this to your init.el to speed up cursor movement in the repl buffer with many presentations: - -(add-hook 'slime-repl-mode-hook - (lambda () - (setf parse-sexp-lookup-properties nil))) -")) - -(defun swank::present-in-emacs (value-or-values &key (separated-by " ")) - "Present VALUE in the Emacs repl buffer of the current thread." - (unless (consp value-or-values) - (setf value-or-values (list value-or-values))) - (flet ((present (value) - (if (stringp value) - (swank::send-to-emacs `(:write-string ,value)) - (let ((id (swank::save-presented-object value))) - (swank::send-to-emacs `(:write-string ,(prin1-to-string value) ,id)))))) - (map nil (let ((first-time-p t)) - (lambda (value) - (when (and (not first-time-p) - separated-by) - (present separated-by)) - (present value) - (setf first-time-p nil))) - value-or-values)) - (values)) - -(defmethod append-message ((category log-category) (appender slime-repl-log-appender) - message level) - (when (swank::default-connection) - (swank::with-connection ((swank::default-connection)) - (multiple-value-bind (second minute hour day month year) - (decode-universal-time (get-universal-time)) - (declare (ignore second day month year)) - (swank::present-in-emacs (format nil - "~2,'0D:~2,'0D ~A/~A: " - hour minute - (symbol-name (name category)) - (symbol-name level)))) - (if (consp message) - (let ((format-control (when (stringp (first message)) - (first message))) - (args (if (stringp (first message)) - (rest message) - message))) - (when format-control - (setf message (apply #'format nil format-control args))) - (swank::present-in-emacs message) - (awhen (and format-control - (> (verbosity-of appender) 1) - (remove-if (lambda (el) - (or (stringp el) - (null el))) - args)) - (swank::present-in-emacs " (") - (swank::present-in-emacs it) - (swank::present-in-emacs ")"))) - (swank::present-in-emacs message)) - (swank::present-in-emacs #.(string #\Newline))))) - (defun arnesi-logger-inspector-lookup-hook (form) (when (symbolp form) (if-bind logger (get-logger form) @@ -402,13 +300,6 @@ (when-bind logger (get-logger logger-name) (values logger t))))))
-(awhen (find-symbol (symbol-name '#:*inspector-dwim-lookup-hooks*) :swank) - (pushnew 'arnesi-logger-inspector-lookup-hook (symbol-value it))) - -(defun make-slime-repl-log-appender (&rest args &key (verbosity 2)) - (remf-keywords args :verbosity) - (apply #'make-instance 'slime-repl-log-appender :verbosity verbosity args)) - (defclass file-log-appender (stream-log-appender) ((log-file :initarg :log-file :accessor log-file :documentation "Name of the file to write log messages to."))
Modified: branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp (original) +++ branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp Mon Feb 18 05:46:33 2008 @@ -224,7 +224,6 @@ #:brief-stream-log-appender #:verbose-stream-log-appender #:make-stream-log-appender - #:make-slime-repl-log-appender #:file-log-appender #:make-file-log-appender #:deflogger
Added: branches/trunk-reorg/thirdparty/arnesi/src/slime-extras.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/arnesi/src/slime-extras.lisp Mon Feb 18 05:46:33 2008 @@ -0,0 +1,114 @@ +(in-package :arnesi) + +;;;; * Logging slime integration + +(defclass slime-repl-log-appender (appender) + () + (:documentation "Logs to the slime repl when there's a valid swank::*emacs-connection* bound. Arguments are presented ready for inspection. + +You may want to add this to your init.el to speed up cursor movement in the repl buffer with many presentations: + +(add-hook 'slime-repl-mode-hook + (lambda () + (setf parse-sexp-lookup-properties nil))) +")) + +(awhen (find-symbol (symbol-name '#:*inspector-dwim-lookup-hooks*) :swank) + (pushnew 'arnesi-logger-inspector-lookup-hook (symbol-value it))) + +(defun make-slime-repl-log-appender (&rest args &key (verbosity 2)) + (remf-keywords args :verbosity) + (apply #'make-instance 'slime-repl-log-appender :verbosity verbosity args)) + +(export '(make-slime-repl-log-appender) :arnesi) + +(defun swank::present-in-emacs (value-or-values &key (separated-by " ")) + "Present VALUE in the Emacs repl buffer of the current thread." + (unless (consp value-or-values) + (setf value-or-values (list value-or-values))) + (flet ((present (value) + (if (stringp value) + (swank::send-to-emacs `(:write-string ,value)) + (let ((id (swank::save-presented-object value))) + (swank::send-to-emacs `(:write-string ,(prin1-to-string value) ,id)))))) + (map nil (let ((first-time-p t)) + (lambda (value) + (when (and (not first-time-p) + separated-by) + (present separated-by)) + (present value) + (setf first-time-p nil))) + value-or-values)) + (values)) + +(defmethod append-message ((category log-category) (appender slime-repl-log-appender) + message level) + (when (swank::default-connection) + (swank::with-connection ((swank::default-connection)) + (multiple-value-bind (second minute hour day month year) + (decode-universal-time (get-universal-time)) + (declare (ignore second day month year)) + (swank::present-in-emacs (format nil + "~2,'0D:~2,'0D ~A/~A: " + hour minute + (symbol-name (name category)) + (symbol-name level)))) + (if (consp message) + (let ((format-control (when (stringp (first message)) + (first message))) + (args (if (stringp (first message)) + (rest message) + message))) + (when format-control + (setf message (apply #'format nil format-control args))) + (swank::present-in-emacs message) + (awhen (and format-control + (> (verbosity-of appender) 1) + (remove-if (lambda (el) + (or (stringp el) + (null el))) + args)) + (swank::present-in-emacs " (") + (swank::present-in-emacs it) + (swank::present-in-emacs ")"))) + (swank::present-in-emacs message)) + (swank::present-in-emacs #.(string #\Newline))))) + +(defun log-level-setter-inspector-action-for (prompt current-level setter) + (lambda () + (with-simple-restart + (abort "Abort setting log level") + (let ((value-string (swank::eval-in-emacs + `(condition-case c + (let ((arnesi-log-levels '(,@(mapcar #'string-downcase (coerce *log-level-names* 'list))))) + (slime-read-object ,prompt :history (cons 'arnesi-log-levels ,(1+ current-level)) + :initial-value ,(string-downcase (log-level-name-of current-level)))) + (quit nil))))) + (when (and value-string + (not (string= value-string ""))) + (funcall setter (eval (let ((*package* #.(find-package :arnesi))) + (read-from-string value-string))))))))) + +(defmethod swank:emacs-inspect ((category log-category)) + (let ((class (class-of category))) + (values "A log-category." + `("Class: " (:value ,class) (:newline) + "Runtime level: " (:value ,(log.level category) + ,(string (log-level-name-of (log.level category)))) + " " + (:action "[set level]" ,(log-level-setter-inspector-action-for + "Set runtime log level to (evaluated): " + (log.level category) + (lambda (value) + (setf (log.level category) value)))) + (:newline) + "Compile-time level: " (:value ,(log.compile-time-level category) + ,(string (log-level-name-of (log.compile-time-level category)))) + " " + (:action "[set level]" ,(log-level-setter-inspector-action-for + "Set compile-time log level to (evaluated): " + (log.compile-time-level category) + (lambda (value) + (setf (log.compile-time-level category) value)))) + (:newline) + ,@(swank::all-slots-for-inspector category)))))