From 62477eb3fde823610df560eaec0f2c0a6676184f Mon Sep 17 00:00:00 2001
From: Michael Weber <michaelw@foldr.org>
Date: Mon, 28 Jul 2008 15:09:27 +0200
Subject: [PATCH] Symbol name conflict UI (SBCL-only)

---
 contrib/slime-sb-name-conflict.el   |   11 ++
 contrib/swank-sb-name-conflict.lisp |  216 +++++++++++++++++++++++++++++++++++
 2 files changed, 227 insertions(+), 0 deletions(-)
 create mode 100644 contrib/slime-sb-name-conflict.el
 create mode 100644 contrib/swank-sb-name-conflict.lisp

diff --git a/contrib/slime-sb-name-conflict.el b/contrib/slime-sb-name-conflict.el
new file mode 100644
index 0000000..7133fe4
--- /dev/null
+++ b/contrib/slime-sb-name-conflict.el
@@ -0,0 +1,11 @@
+;;; slime-sb-name-conflict.el --- SLIME symbol name conflict resolution
+;; (SBCL-only, at the moment)
+;;
+;; Author: Michael Weber <michaelw@foldr.org>, 2008
+;; License: GNU GPL (same license as Emacs)
+;;
+
+;;; Code
+(slime-require :swank-sb-name-conflict)
+
+(provide 'slime-sb-name-conflict)
diff --git a/contrib/swank-sb-name-conflict.lisp b/contrib/swank-sb-name-conflict.lisp
new file mode 100644
index 0000000..1e44890
--- /dev/null
+++ b/contrib/swank-sb-name-conflict.lisp
@@ -0,0 +1,216 @@
+;;; SLIME symbol name conflict resolution (SBCL-only, at the moment)
+;; Author: Michael Weber <michaelw@foldr.org>, 2008
+
+;;; Installation
+;; * Apply patch to SLIME
+;; * Compile and load this file; or use
+;;   (slime-setup '(... slime-sb-name-conflict))
+;; * (Set `slime-enable-evaluate-in-emacs' to true.)
+;; * Try examples at end of file
+
+;;; Documentation
+;; Requires SBCL >= 1.0.19.15
+;;
+;; Two new restarts are provided for condition SB-EXT:NAME-CONFLICT:
+;; 1. SLIME-RESOLVE-CONFLICT
+;;    choose which symbol to import with minibuffer history
+;;
+;; 2. SLIME-RESOLVE-USING-PACKAGE
+;;    Since (1) is not useful in the presence of many conflicts, this
+;;    restart resolves ALL conflicts caused by the current interaction
+;;    (evaluation, compile-file, etc.) by preferring symbols from the
+;;    package selected from minibuffer.  If none of the clashing
+;;    symbols are from the selected package, SLIME drops into the
+;;    debugger again.
+;;
+;;    Newly accessible symbols are printed to the REPL.
+
+;;; TODO:
+;; * A better protocol, after we know what other Lisps can do
+
+;;; Code
+(in-package #:swank)
+
+;;;; Name Conflict UI
+(defun name-conflict-resolve-interactively/symbol (conflict-set)
+  (let* ((names (let ((*package* (find-package '#:keyword)))
+                  (mapcar #'prin1-to-string conflict-set)))
+         (chosen-name
+          (eval-in-emacs
+           `(let ((symbol-names ',names))
+              (read-string "Symbol: " ,(first names)
+                           '(symbol-names . 1)
+                           ,(first names))))))
+    (list (handler-case (parse-symbol-or-lose chosen-name)
+            (error ()
+              ;; could be uninterned symbol, #:FOO
+              ;; => try by name
+              (elt conflict-set
+                   (or (position chosen-name names :test #'equalp)
+                       (error "Unknown symbol: ~A." chosen-name))))))))
+
+(defun name-conflict-resolve-interactively/package (packages)
+  (let* ((package-names (mapcar #'package-name packages))
+         (chosen-name
+          (eval-in-emacs
+           `(let ((packages ',package-names))
+              (read-string "Package: " ,(first package-names)
+                           '(packages . 1)
+                           ,(first package-names))))))
+    (list (or (find-package chosen-name)
+              (error "XXX Not a package name: ~S" chosen-name)))))
+
+;;;; Backend
+(defvar *name-conflict-resolution* nil
+  "Name conflict resolution strategy.
+Value should be either NIL \(no conflict resolution) or a function
+designator.")
+
+(defun name-conflict-invoke-resolution (condition)
+  (when *name-conflict-resolution*
+    (funcall *name-conflict-resolution* condition)))
+
+;;;;; SBCL-Specific Bits
+#+sbcl
+(progn
+  (defun name-conflict-resolve-using-package (package condition)
+    (flet ((find-package-symbol (package conflict-set)
+             (let ((found (member-if (lambda (x)
+                                       (eq (symbol-package x) package))
+                                     conflict-set)))
+               (if found
+                   (car found)
+                   (return-from name-conflict-resolve-using-package)))))
+      (let* ((conflict-set (sb-ext:name-conflict-symbols condition))
+             (symbol (find-package-symbol package conflict-set)))
+        (let ((*package* (find-package '#:keyword)))
+          (format t "~&; Symbol ~S made accessible in ~A.~%"
+                  symbol
+                  (package-error-package condition)))
+        (invoke-restart 'sb-ext:resolve-conflict symbol))))
+
+  (swank-backend::defimplementation call-with-request-environment (function)
+    (restart-bind
+        ((slime-resolve-conflict
+          (lambda (symbol)
+            (invoke-restart 'sb-ext:resolve-conflict symbol))
+           :report-function
+           (lambda (stream)
+             (format stream "Resolve name conflict. [SLIME]"))
+           :interactive-function
+           (lambda ()
+             (name-conflict-resolve-interactively/symbol
+              (sb-ext:name-conflict-symbols *swank-debugger-condition*)))
+           :test-function
+           (lambda (condition)
+             (find-restart 'sb-ext:resolve-conflict condition)))
+         (slime-resolve-using-package
+          (lambda (package)
+            (setf *name-conflict-resolution*
+                  (lambda (condition)
+                    (name-conflict-resolve-using-package package condition)))
+            (error *swank-debugger-condition*))
+           :report-function
+           (lambda (stream)
+             (format stream
+                     "Resolve all conflicts in favor of one package. [SLIME]"))
+           :interactive-function
+           (lambda ()
+             (let* ((symbols
+                     (sb-ext:name-conflict-symbols *swank-debugger-condition*))
+                    (packages (delete-duplicates
+                               (mapcar #'symbol-package symbols))))
+               (name-conflict-resolve-interactively/package packages)))
+           :test-function
+           (lambda (condition)
+             (find-restart 'sb-ext:resolve-conflict condition))))
+      #-(and)
+      (when (find-restart 'sb-ext:resolve-conflict)
+        (when (find-restart 'slime-resolve-using-package)
+          (push (find-restart 'slime-resolve-using-package) *sldb-restarts*))
+        (when (find-restart 'slime-resolve-conflict)
+          (push (find-restart 'slime-resolve-conflict) *sldb-restarts*)))
+      (handler-bind ((sb-ext:name-conflict #'name-conflict-invoke-resolution))
+        (let ((*name-conflict-resolution* nil))
+          (funcall function))))))
+
+(values)
+;;;; Tests
+#||
+;;; test
+(defpackage "A"
+  (:use #:cl)
+  (:export "A0" "A1"))
+
+(in-package #:a)
+(progn
+  (defun a0 () 'a0)
+  (defun a1 () 'a1))
+
+(defpackage "B"
+  (:use #:cl)
+  (:export "A0" "A1"))
+
+(in-package #:b)
+(progn
+  (defun a0 () 'a0)
+  (defun a1 () 'a1))
+
+(ignore-errors (delete-package "AB"))
+(defpackage "AB"
+  (:use #:cl)
+  (:export "A0"))
+
+(in-package #:ab)
+
+(use-package '("A" "B") (find-package "AB"))
+
+||#
+
+#||
+(defpackage "X"
+  (:use #:cl)
+  (:export "X0"))
+
+(in-package #:x)
+(defun x0 () 'x0)
+
+(defpackage "Y"
+  (:use #:cl)
+  (:export "X0"))
+
+(in-package #:y)
+(defun x0 () 'x0)
+
+(ignore-errors (delete-package "XY"))
+(defpackage "XY"
+  (:use #:cl))
+
+(in-package #:xy)
+
+(use-package '("X" "Y") (find-package "XY"))
+
+(in-package #:cl-user)
+||#
+
+#||
+unintern bug:
+;; EXPORT W/ USE & PRESENT & UNINTERN
+(DEFPACKAGE "FOO" (:INTERN "SYM"))
+(DEFPACKAGE "BAR" (:EXPORT "SYM"))
+(DEFPACKAGE "BAZ" (:USE "FOO" "BAR"))
+(handler-bind ((sb-ext:name-conflict
+                (lambda (condition)
+                  (declare (ignore condition))
+                  (invoke-restart 'sb-ext:resolve-conflict 'FOO::SYM))))
+  (EXPORT 'FOO::SYM "FOO"))
+;; (DEFPACKAGE "BAZ" (:USE "FOO" "BAR") (:SHADOWING-IMPORT-FROM "FOO" "SYM"))
+(UNINTERN 'BAZ::SYM "BAZ")
+||#
+
+#||
+;; IMPORT w/ shadowing
+(DEFPACKAGE "BAR" (:EXPORT "NIL"))
+(DEFPACKAGE "BAZ" (:USE) (:SHADOW "NIL"))
+(IMPORT '(CL:NIL BAR::NIL) "BAZ")
+||#
-- 
1.6.0.rc1.2.ge0842b

