[bknr-cvs] r2533 - in branches/trunk-reorg/thirdparty/arnesi: . src
ksprotte at common-lisp.net
ksprotte at common-lisp.net
Mon Feb 18 10:46:33 UTC 2008
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)))))
More information about the Bknr-cvs
mailing list