335 lines
12 KiB
Common Lisp
335 lines
12 KiB
Common Lisp
;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities
|
||
;;; to portions of output
|
||
;;;
|
||
;;; Authors: Alan Ruttenberg <alanr-l@mumble.net>
|
||
;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
|
||
;;; Helmut Eller <heller@common-lisp.net>
|
||
;;;
|
||
;;; License: This code has been placed in the Public Domain. All warranties
|
||
;;; are disclaimed.
|
||
|
||
(in-package :swank)
|
||
|
||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||
(swank-require :swank-presentations))
|
||
|
||
;; This file contains a mechanism for printing to the slime repl so
|
||
;; that the printed result remembers what object it is associated
|
||
;; with. This extends the recording of REPL results.
|
||
;;
|
||
;; There are two methods:
|
||
;;
|
||
;; 1. Depends on the ilisp bridge code being installed and ready to
|
||
;; intercept messages in the printed stream. We encode the
|
||
;; information with a message saying that we are starting to print
|
||
;; an object corresponding to a given id and another when we are
|
||
;; done. The process filter notices these and adds the necessary
|
||
;; text properties to the output.
|
||
;;
|
||
;; 2. Use separate protocol messages :presentation-start and
|
||
;; :presentation-end for sending presentations.
|
||
;;
|
||
;; We only do this if we know we are printing to a slime stream,
|
||
;; checked with the method slime-stream-p. Initially this checks for
|
||
;; the knows slime streams looking at *connections*. In cmucl, sbcl, and
|
||
;; openmcl it also checks if it is a pretty-printing stream which
|
||
;; ultimately prints to a slime stream.
|
||
;;
|
||
;; Method 1 seems to be faster, but the printed escape sequences can
|
||
;; disturb the column counting, and thus the layout in pretty-printing.
|
||
;; We use method 1 when a dedicated output stream is used.
|
||
;;
|
||
;; Method 2 is cleaner and works with pretty printing if the pretty
|
||
;; printers support "annotations". We use method 2 when no dedicated
|
||
;; output stream is used.
|
||
|
||
;; Control
|
||
(defvar *enable-presenting-readable-objects* t
|
||
"set this to enable automatically printing presentations for some
|
||
subset of readable objects, such as pathnames." )
|
||
|
||
;; doing it
|
||
|
||
(defmacro presenting-object (object stream &body body)
|
||
"What you use in your code. Wrap this around some printing and that text will
|
||
be sensitive and remember what object it is in the repl"
|
||
`(presenting-object-1 ,object ,stream #'(lambda () ,@body)))
|
||
|
||
(defmacro presenting-object-if (predicate object stream &body body)
|
||
"What you use in your code. Wrap this around some printing and that text will
|
||
be sensitive and remember what object it is in the repl if predicate is true"
|
||
(let ((continue (gensym)))
|
||
`(let ((,continue #'(lambda () ,@body)))
|
||
(if ,predicate
|
||
(presenting-object-1 ,object ,stream ,continue)
|
||
(funcall ,continue)))))
|
||
|
||
;;; Get pretty printer patches for SBCL at load (not compile) time.
|
||
#+#:disable-dangerous-patching ; #+sbcl
|
||
(eval-when (:load-toplevel)
|
||
(handler-bind ((simple-error
|
||
(lambda (c)
|
||
(declare (ignore c))
|
||
(let ((clobber-it (find-restart 'sb-kernel::clobber-it)))
|
||
(when clobber-it (invoke-restart clobber-it))))))
|
||
(sb-ext:without-package-locks
|
||
(swank/sbcl::with-debootstrapping
|
||
(load (make-pathname
|
||
:name "sbcl-pprint-patch"
|
||
:type "lisp"
|
||
:directory (pathname-directory
|
||
swank-loader:*source-directory*)))))))
|
||
|
||
(let ((last-stream nil)
|
||
(last-answer nil))
|
||
(defun slime-stream-p (stream)
|
||
"Check if stream is one of the slime streams, since if it isn't we
|
||
don't want to present anything.
|
||
Two special return values:
|
||
:DEDICATED -- Output ends up on a dedicated output stream
|
||
:REPL-RESULT -- Output ends up on the :repl-results target.
|
||
"
|
||
(if (eq last-stream stream)
|
||
last-answer
|
||
(progn
|
||
(setq last-stream stream)
|
||
(if (eq stream t)
|
||
(setq stream *standard-output*))
|
||
(setq last-answer
|
||
(or #+openmcl
|
||
(and (typep stream 'ccl::xp-stream)
|
||
;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure)))
|
||
(slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1)))
|
||
#+cmu
|
||
(or (and (typep stream 'lisp::indenting-stream)
|
||
(slime-stream-p (lisp::indenting-stream-stream stream)))
|
||
(and (typep stream 'pretty-print::pretty-stream)
|
||
(fboundp 'pretty-print::enqueue-annotation)
|
||
(let ((slime-stream-p
|
||
(slime-stream-p (pretty-print::pretty-stream-target stream))))
|
||
(and ;; Printing through CMUCL pretty
|
||
;; streams is only cleanly
|
||
;; possible if we are using the
|
||
;; bridge-less protocol with
|
||
;; annotations, because the bridge
|
||
;; escape sequences disturb the
|
||
;; pretty printer layout.
|
||
(not (eql slime-stream-p :dedicated-output))
|
||
;; If OK, return the return value
|
||
;; we got from slime-stream-p on
|
||
;; the target stream (could be
|
||
;; :repl-result):
|
||
slime-stream-p))))
|
||
#+sbcl
|
||
(let ()
|
||
(declare (notinline sb-pretty::pretty-stream-target))
|
||
(and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))
|
||
(find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty)
|
||
(not *use-dedicated-output-stream*)
|
||
(slime-stream-p (sb-pretty::pretty-stream-target stream))))
|
||
#+allegro
|
||
(and (typep stream 'excl:xp-simple-stream)
|
||
(slime-stream-p (excl::stream-output-handle stream)))
|
||
(loop for connection in *connections*
|
||
thereis (or (and (eq stream (connection.dedicated-output connection))
|
||
:dedicated)
|
||
(eq stream (connection.socket-io connection))
|
||
(eq stream (connection.user-output connection))
|
||
(eq stream (connection.user-io connection))
|
||
(and (eq stream (connection.repl-results connection))
|
||
:repl-result)))))))))
|
||
|
||
(defun can-present-readable-objects (&optional stream)
|
||
(declare (ignore stream))
|
||
*enable-presenting-readable-objects*)
|
||
|
||
;; If we are printing to an XP (pretty printing) stream, printing the
|
||
;; escape sequences directly would mess up the layout because column
|
||
;; counting is disturbed. Use "annotations" instead.
|
||
#+allegro
|
||
(defun write-annotation (stream function arg)
|
||
(if (typep stream 'excl:xp-simple-stream)
|
||
(excl::schedule-annotation stream function arg)
|
||
(funcall function arg stream nil)))
|
||
#+cmu
|
||
(defun write-annotation (stream function arg)
|
||
(if (and (typep stream 'pp:pretty-stream)
|
||
(fboundp 'pp::enqueue-annotation))
|
||
(pp::enqueue-annotation stream function arg)
|
||
(funcall function arg stream nil)))
|
||
#+sbcl
|
||
(defun write-annotation (stream function arg)
|
||
(let ((enqueue-annotation
|
||
(find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty)))
|
||
(if (and enqueue-annotation
|
||
(typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)))
|
||
(funcall enqueue-annotation stream function arg)
|
||
(funcall function arg stream nil))))
|
||
#-(or allegro cmu sbcl)
|
||
(defun write-annotation (stream function arg)
|
||
(funcall function arg stream nil))
|
||
|
||
(defstruct presentation-record
|
||
(id)
|
||
(printed-p)
|
||
(target))
|
||
|
||
(defun presentation-start (record stream truncatep)
|
||
(unless truncatep
|
||
;; Don't start new presentations when nothing is going to be
|
||
;; printed due to *print-lines*.
|
||
(let ((pid (presentation-record-id record))
|
||
(target (presentation-record-target record)))
|
||
(case target
|
||
(:dedicated
|
||
;; Use bridge protocol
|
||
(write-string "<" stream)
|
||
(prin1 pid stream)
|
||
(write-string " " stream))
|
||
(t
|
||
(finish-output stream)
|
||
(send-to-emacs `(:presentation-start ,pid ,target)))))
|
||
(setf (presentation-record-printed-p record) t)))
|
||
|
||
(defun presentation-end (record stream truncatep)
|
||
(declare (ignore truncatep))
|
||
;; Always end old presentations that were started.
|
||
(when (presentation-record-printed-p record)
|
||
(let ((pid (presentation-record-id record))
|
||
(target (presentation-record-target record)))
|
||
(case target
|
||
(:dedicated
|
||
;; Use bridge protocol
|
||
(write-string ">" stream)
|
||
(prin1 pid stream)
|
||
(write-string " " stream))
|
||
(t
|
||
(finish-output stream)
|
||
(send-to-emacs `(:presentation-end ,pid ,target)))))))
|
||
|
||
(defun presenting-object-1 (object stream continue)
|
||
"Uses the bridge mechanism with two messages >id and <id. The first one
|
||
says that I am starting to print an object with this id. The second says I am finished"
|
||
;; this declare special is to let the compiler know that *record-repl-results* will eventually be
|
||
;; a global special, even if it isn't when this file is compiled/loaded.
|
||
(declare (special *record-repl-results*))
|
||
(let ((slime-stream-p
|
||
(and *record-repl-results* (slime-stream-p stream))))
|
||
(if slime-stream-p
|
||
(let* ((pid (swank::save-presented-object object))
|
||
(record (make-presentation-record :id pid :printed-p nil
|
||
:target (if (eq slime-stream-p :repl-result)
|
||
:repl-result
|
||
nil))))
|
||
(write-annotation stream #'presentation-start record)
|
||
(multiple-value-prog1
|
||
(funcall continue)
|
||
(write-annotation stream #'presentation-end record)))
|
||
(funcall continue))))
|
||
|
||
(defun present-repl-results-via-presentation-streams (values)
|
||
;; Override a function in swank.lisp, so that
|
||
;; nested presentations work in the REPL result.
|
||
(let ((repl-results (connection.repl-results *emacs-connection*)))
|
||
(flet ((send (value)
|
||
(presenting-object value repl-results
|
||
(prin1 value repl-results))
|
||
(terpri repl-results)))
|
||
(if (null values)
|
||
(progn
|
||
(princ "; No value" repl-results)
|
||
(terpri repl-results))
|
||
(mapc #'send values)))
|
||
(finish-output repl-results)))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
#+openmcl
|
||
(in-package :ccl)
|
||
|
||
#+openmcl
|
||
(defun monkey-patch-stream-printing ()
|
||
(let ((*warn-if-redefine-kernel* nil)
|
||
(*warn-if-redefine* nil))
|
||
(defun %print-unreadable-object (object stream type id thunk)
|
||
(cond ((null stream) (setq stream *standard-output*))
|
||
((eq stream t) (setq stream *terminal-io*)))
|
||
(swank::presenting-object object stream
|
||
(write-unreadable-start object stream)
|
||
(when type
|
||
(princ (type-of object) stream)
|
||
(stream-write-char stream #\space))
|
||
(when thunk
|
||
(funcall thunk))
|
||
(if id
|
||
(%write-address object stream #\>)
|
||
(pp-end-block stream ">"))
|
||
nil))
|
||
(defmethod print-object :around ((pathname pathname) stream)
|
||
(swank::presenting-object-if
|
||
(swank::can-present-readable-objects stream)
|
||
pathname stream (call-next-method))))
|
||
(ccl::def-load-pointers clear-presentations ()
|
||
(swank::clear-presentation-tables)))
|
||
|
||
(in-package :swank)
|
||
|
||
#+cmu
|
||
(progn
|
||
(fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body)
|
||
(presenting-object object stream
|
||
(fwrappers:call-next-function)))
|
||
|
||
(fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth)
|
||
(presenting-object-if (can-present-readable-objects stream) pathname stream
|
||
(fwrappers:call-next-function)))
|
||
|
||
(defun monkey-patch-stream-printing ()
|
||
(fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper)
|
||
(fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper)))
|
||
|
||
#+sbcl
|
||
(progn
|
||
(defvar *saved-%print-unreadable-object*
|
||
(fdefinition 'sb-impl::%print-unreadable-object))
|
||
|
||
(defun monkey-patch-stream-printing ()
|
||
(sb-ext:without-package-locks
|
||
(when (eq (fdefinition 'sb-impl::%print-unreadable-object)
|
||
*saved-%print-unreadable-object*)
|
||
(setf (fdefinition 'sb-impl::%print-unreadable-object)
|
||
(lambda (object stream &rest args)
|
||
(presenting-object object stream
|
||
(apply *saved-%print-unreadable-object*
|
||
object stream args)))))
|
||
(defmethod print-object :around ((object pathname) stream)
|
||
(presenting-object object stream
|
||
(call-next-method))))))
|
||
|
||
#+allegro
|
||
(progn
|
||
(excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation)
|
||
(swank::presenting-object object stream (excl:call-next-fwrapper)))
|
||
(excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth)
|
||
(presenting-object-if (can-present-readable-objects stream) pathname stream
|
||
(excl:call-next-fwrapper)))
|
||
(defun monkey-patch-stream-printing ()
|
||
(excl:fwrap 'excl::print-unreadable-object-1
|
||
'print-unreadable-present 'presenting-unreadable-wrapper)
|
||
(excl:fwrap 'excl::pathname-printer
|
||
'print-pathname-present 'presenting-pathname-wrapper)))
|
||
|
||
#-(or allegro sbcl cmu openmcl)
|
||
(defun monkey-patch-stream-printing ()
|
||
(values))
|
||
|
||
;; Hook into SWANK.
|
||
|
||
(defslimefun init-presentation-streams ()
|
||
(monkey-patch-stream-printing)
|
||
;; FIXME: import/use swank-repl to avoid package qualifier.
|
||
(setq swank-repl:*send-repl-results-function*
|
||
'present-repl-results-via-presentation-streams))
|
||
|
||
(provide :swank-presentation-streams)
|