/emacs/emacs.d.symlink/elpa/slime-20140305.1205/contrib/swank-presentation-streams.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)

(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.
#+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-backend::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)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Example: Tell openmcl and cmucl to always present unreadable objects. try (describe 'class) 
#+openmcl
(in-package :ccl)
#+openmcl
(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))))

#+openmcl
(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)))

  (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))
  (sb-ext:without-package-locks 
    (setf (fdefinition 'sb-impl::%print-unreadable-object)
	  (lambda (object stream type identity body)
	    (presenting-object object stream
	      (funcall *saved-%print-unreadable-object* 
		       object stream type identity body))))
    (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)))
  (excl:fwrap 'excl::print-unreadable-object-1 
	      'print-unreadable-present 'presenting-unreadable-wrapper)
  (excl:fwrap 'excl::pathname-printer 
	      'print-pathname-present 'presenting-pathname-wrapper))

;; Hook into SWANK.

(setq *send-repl-results-function* 'present-repl-results-via-presentation-streams)

(provide :swank-presentation-streams)