[slime-cvs] CVS slime/contrib

[heller]

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv9753

Modified Files:
	ChangeLog 
Added Files:
	swank-clipboard.lisp slime-clipboard.el 
Log Message:
Add a simple object clipboard.

* swank-clipboard.lisp: New file.
* slime-clipboard.el: New file.



--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/08/07 15:24:08	1.117
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/08/12 13:03:15	1.118
@@ -1,3 +1,10 @@
+2008-08-12  Helmut Eller  <heller at common-lisp.net>
+
+	Add a simple object clipboard.
+
+	* swank-clipboard.lisp: New file.
+	* slime-clipboard.el: New file.
+
 2008-08-07  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-fancy.el: Add slime-mdot-fu and slime-package-fu.

--- /project/slime/cvsroot/slime/contrib/swank-clipboard.lisp	2008/08/12 13:03:15	NONE
+++ /project/slime/cvsroot/slime/contrib/swank-clipboard.lisp	2008/08/12 13:03:15	1.1
;;; swank-clipboard.lisp --- Object clipboard
;;
;; Written by Helmut Eller in 2008.
;; License: Public Domain

(defpackage :swank-clipboard
  (:use :cl)
  (:import-from :swank :defslimefun :with-buffer-syntax :destructure-case))

(in-package :swank-clipboard)

(defstruct clipboard entries (counter 0))

(defvar *clipboard* (make-clipboard))

(defslimefun add (datum)
  (let ((value (destructure-case datum
		 ((:string string package)
		  (with-buffer-syntax (package)
		    (eval (read-from-string string))))
		 ((:inspector part) 
		  (swank:inspector-nth-part part))
		 ((:sldb frame var)
		  (swank-backend:frame-var-value frame var)))))
    (clipboard-add value)
    (format nil "Added: ~a"
	    (entry-to-string (1- (length (clipboard-entries *clipboard*)))))))

(defslimefun entries ()
  (loop for (ref . value) in (clipboard-entries *clipboard*)
	collect `(,ref . ,(to-line value))))

(defslimefun delete-entry (entry)
  (let ((msg (format nil "Deleted: ~a" (entry-to-string entry))))
    (clipboard-delete-entry entry)
    msg))

(defslimefun entry-to-ref (entry)
  (destructuring-bind (ref . value) (clipboard-entry entry)
    (list ref (to-line value 5))))

(defun clipboard-add (value)
  (setf (clipboard-entries *clipboard*)
	(append (clipboard-entries *clipboard*) 
		(list (cons (incf (clipboard-counter *clipboard*))
			    value)))))

(defun clipboard-ref (ref)
  (let ((tail (member ref (clipboard-entries *clipboard*) :key #'car)))
    (cond (tail (cdr (car tail)))
	  (t (error "Invalid clipboard ref: ~s" ref)))))

(defun clipboard-entry (entry)
  (elt (clipboard-entries *clipboard*) entry))

(defun clipboard-delete-entry (index)
  (let* ((list (clipboard-entries *clipboard*))
	 (tail (nthcdr index list)))
    (setf (clipboard-entries *clipboard*)
	  (append (ldiff list tail) (cdr tail)))))

(defun entry-to-string (entry)
  (destructuring-bind (ref . value) (clipboard-entry entry)
    (format nil "#@~d(~a)" ref (to-line value))))

(defun to-line  (object &optional (width 75))
  (with-output-to-string (*standard-output*)
    (write object :right-margin width :lines 1)))
--- /project/slime/cvsroot/slime/contrib/slime-clipboard.el	2008/08/12 13:03:15	NONE
+++ /project/slime/cvsroot/slime/contrib/slime-clipboard.el	2008/08/12 13:03:15	1.1
;;; slime-scratch.el --- Object clipboard for SLIME
;;
;; Author: Helmut Eller  <heller at common-lisp.net>
;; License: GNU GPL (same license as Emacs)
;;
;; This add a few commands to put objects into a clipboard and
;; to insert textual references to those objects.
;;
;; The clipboard command prefix is C-c @.
;;
;; C-c @ +   adds an object to the clipboard
;; C-c @ @   inserts a reference to an object in the clipboard
;; C-c @ ?   displays the clipboard
;;
;; This package also also binds the + key in the inspector and
;; debugger to add the object at point to the clipboard.
;;

(require 'slime)
(slime-require :swank-clipboard)

(define-derived-mode slime-clipboard-mode fundamental-mode
  "Slime-Clipboard"
  "SLIME Clipboad Mode.

\\{slime-clipboard-mode-map}")

(slime-define-keys slime-clipboard-mode-map
  ("g" 'slime-clipboard-redisplay)
  ((kbd "C-k") 'slime-clipboard-delete-entry)
  ("i" 'slime-clipboard-inspect))

(defvar slime-clipboard-map (make-sparse-keymap))

(slime-define-keys slime-clipboard-map
  ("?" 'slime-clipboard-display)
  ("+" 'slime-clipboard-add)
  ("@" 'slime-clipboard-ref))

(define-key slime-mode-map (kbd "C-c @") slime-clipboard-map)
(define-key slime-repl-mode-map (kbd "C-c @") slime-clipboard-map)

(slime-define-keys slime-inspector-mode-map
  ("+" 'slime-clipboard-add-from-inspector))

(slime-define-keys sldb-mode-map
  ("+" 'slime-clipboard-add-from-sldb))

(defun slime-clipboard-add (exp package)
  "Add an object to the clipboard."
  (interactive (list (slime-read-from-minibuffer 
                      "Add to clipboard (evaluated): "
                      (slime-sexp-at-point))
		     (slime-current-package)))
  (slime-clipboard-add-internal `(:string ,exp ,package)))

(defun slime-clipboard-add-internal (datum)
  (slime-eval-async `(swank-clipboard:add ',datum) 
		    (lambda (result) (message "%s" result))))

(defun slime-clipboard-display ()
  "Display the content of the clipboard."
  (interactive)
  (slime-eval-async `(swank-clipboard:entries) 
		    #'slime-clipboard-display-entries))

(defun slime-clipboard-display-entries (entries)
  (slime-with-popup-buffer ("*Slime Clipboard*")
    (slime-clipboard-mode)
    (slime-clipboard-insert-entries entries)))

(defun slime-clipboard-insert-entries (entries)
  (let ((fstring "%2s %3s %s\n"))
    (insert (format fstring "Nr" "Id" "Value")
            (format fstring "--" "--" "-----" ))
    (save-excursion
      (loop for i from 0 for (ref . value) in entries do
	    (slime-insert-propertized `(slime-clipboard-entry ,i
					slime-clipboard-ref ,ref)
				      (format fstring i ref value))))))

(defun slime-clipboard-redisplay ()
  "Update the clipboard buffer."
  (interactive)
  (slime-eval-async 
   `(swank-clipboard:entries) 
   (lambda (entries) 
     (let ((inhibit-read-only t))
       (slime-save-coordinates (point)
	 (erase-buffer)
	 (slime-clipboard-insert-entries entries))))))

(defun slime-clipboard-entry-at-point ()
  (or (get-text-property (point) 'slime-clipboard-entry)
      (error "No clipboard entry at point")))

(defun slime-clipboard-ref-at-point ()
  (or (get-text-property (point) 'slime-clipboard-ref)
      (error "No clipboard ref at point")))

(defun slime-clipboard-inspect (&optional entry)
  "Inspect the current clipboard entry."
  (interactive (list (slime-clipboard-ref-at-point)))
  (slime-inspect (prin1-to-string `(swank-clipboard::clipboard-ref ,entry))))

(defun slime-clipboard-delete-entry (&optional entry)
  "Delete the current entry from the clipboard."
  (interactive (list (slime-clipboard-entry-at-point)))
  (slime-eval-async `(swank-clipboard:delete-entry ,entry)
		    (lambda (result) 
		      (slime-clipboard-redisplay)
		      (message "%s" result))))

(defun slime-clipboard-ref ()
  "Ask for a clipboard entry number and insert a reference to it."
  (interactive)
  (slime-clipboard-read-entry-number #'slime-clipboard-insert-ref))
  
;; insert a reference to clipboard entry ENTRY at point.  The text
;; receives a special 'display property to make it look nicer.  We
;; remove this property in a modification when a user tries to modify
;; he real text.
(defun slime-clipboard-insert-ref (entry)
  (destructuring-bind (ref . string) 
      (slime-eval `(swank-clipboard:entry-to-ref ,entry))
    (slime-insert-propertized
     `(display ,(format "#@%d%s" ref string)
	       modification-hooks (slime-clipboard-ref-modified)
	       rear-nonsticky '(modification-hooks))
     (format "(swank-clipboard::clipboard-ref %d)" ref))))

(defun slime-clipboard-ref-modified (start end)
  (when (get-text-property start 'display)
    (let ((inhibit-modification-hooks t))
      (save-excursion
	(goto-char start)
	(destructuring-bind (start end) (slime-property-bounds 'display)
	  (remove-list-of-text-properties start end 
					  '(display modification-hooks)))))))

;; Read a entry number.
;; Written in CPS because the display the clipboard before reading.
(defun slime-clipboard-read-entry-number (k)
  (slime-eval-async 
   `(swank-clipboard:entries) 
   (slime-rcurry
    (lambda (entries window-config k)
      (slime-clipboard-display-entries entries)
      (let ((entry (unwind-protect
		       (read-from-minibuffer "Entry number: " nil nil t)
		     (set-window-configuration window-config))))
	(funcall k entry)))
    (current-window-configuration)
    k)))

(defun slime-clipboard-add-from-inspector ()
  (interactive)
  (let ((part (or (get-text-property (point) 'slime-part-number)
		  (error "No part at point"))))
    (slime-clipboard-add-internal `(:inspector ,part))))

(defun slime-clipboard-add-from-sldb ()
  (interactive)
  (slime-clipboard-add-internal 
   `(:sldb ,(sldb-frame-number-at-point) 
	   ,(sldb-var-number-at-point))))

(provide 'slime-clipboard)