;;; -*- Mode: LISP; Package: CCL; -*-
;;;
;;;   Bugs-To: <terje@in-progress.com>
;;;
;;; Use MCL as a development environment for other Common LISPs such as OpenMCL.
;;; 
;;; Copyright (C) 2007 Terje Norderhaug <terje@in-progress.com>
;;; Version 0.3 (alpha level)
;;;
;;; You are hereby granted the rights to distribute and use this
;;; software as governed by the terms of the Lisp Lesser GNU Public
;;; License (http://opensource.franz.com/preamble.html), known as the
;;; LLGPL.
;;;
;;; This software is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

;;; Has been tested on MCL 5.1 with OpenMCL (Version 1.1-pre-070722 (DarwinPPC32)) as target.
;;; For future versions see <http://www.in-progress.com/src/>.

#| HISTORY
2007-Oct-18 terje Released on the Info-MCL mailing list.
2007-Oct-19 terje Introduced swank-client class with methods for extandability.
2007-Oct-19 terje Support for multiple values in the result.
2007-Oct-19 terje Output in openMCL is written to the listener.
2007-Oct-20 terje Restarts dialog lists restarts from remote lisp during a break.
2007-Oct-20 terje Setting package in remote LISP is reflected in the package indicator of minibuffer.
2007-Oct-22 terje V0.2a released on Info-MCL.
2007-Oct-29 terje Macro to make dispatch more readable, added dispatch handlers for all events. 
2007-Oct-29 terje Apropos dialog linked to remote LISP (core functionality, not details).
2007-Oct-29 terje Sets the package name in the fred Minibuffer.
2007-Oct-30 terje Compatible with the Fred Package Indicator <http://www.in-progress.com/src/fred-package-indicator.lisp>
2007-Oct-30 terje Trace dialog linked to remote LISP (core functionality, not details).
2007-Oct-30 terje Packages and *package* inspectors on the Tools menu displays remote packages.
2007-Oct-31 terje V0.3a released.
|#

#| HOW TO USE

You need to have MCL <http://www.digitool.com> and another Common LISP such as 
Closure CL (aka OpenMCL) <http://openmcl.clozure.com>, referred to below as the "remote" Common LISP.

A. The remote Common LISP should run a Swank server, which is available as part of SLIME:

1. Download SLIME from <http://common-lisp.net/project/slime/>.
2. Start the remote Common LISP environment.
3. Load or execute <swank-loader.lisp> from the SLIME distribution into the remote LISP environment.
4. Evaluate (swank::start-server "random-filename") to start the swank server on the remote LISP.

B. Activate the Swank client for MCL:

1. Load or execute <swank-client.lisp> into MCL (available from http://www.in-progress.com/src/). 
2. Load or execute <mcl-swank-client.lisp> (this file) into MCL.
3. Evaluate (make-instance 'ccl::swank-listener :port port) with the port from swank::start-server.

C. Use the remote LISP environment from MCL:

Forms executed in the Swank Listener or in Fred with the Swank Listener as target will
be evaluated in the remote Common LISP environment. Execute All and Execute Selection in 
Fred also works. Errors are reported including a rudimentary backtrace.

Execute these forms in the Swank Listener to verify that they run in the remote environment:

(lisp-implementation-type)
(lisp-implementation-version)

D. Contribute to the development:

This is a work-in-progress, and your participation would be appreciated! This includes
making the core functionality work flawlessly, particularly when it comes to handling
debugging (break, trace, etc).

Much of the MCL development environment is not yet supported for the remote LISP, 
including the dialogs for Get Info, Trace, Backtrace, the Inspector and Processes.
However, the Swank protocol makes implementing support for these quite feasible. Perhaps
you can help?

This client works by communicating with a Swank server using events. You can see this in action
by tracing the event dispatcher, which is used for both outgoing and incoming events: 

(TRACE SWANK-CLIENT::SLIME-DISPATCH-EVENT)

|#

; (make-instance 'ccl::swank-listener :port 53190)

(in-package :ccl)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MODE

(defparameter *remote-lisp-mode* :auto)

(defun remote-lisp-mode ()
  (case *remote-lisp-mode*
    (:auto
     (typep (front-window :class 'listener) 'swank-listener))
    (null NIL)
    (otherwise T)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SWANK CLIENT

(defclass swank-client ()
  ((connection))
  (:default-initargs
    :host "localhost"))

(defvar *stream->swank-client* (make-hash-table :test 'eq :weak :key))

(defmethod initialize-instance ((client swank-client) &key host port)
  (prog1
    (call-next-method)
    (with-slots (connection) client
      (setf connection
            (swank-client::slime-net-connect host port))
      (setf (gethash connection *stream->swank-client*) client))))

(defstruct remote-object
  (value))

(defmethod print-object ((object remote-object) out)
  (write-string (remote-object-value object) out))

(defmethod swank-client-package ((client swank-client))
  (swank-client::slime-current-package (swank-client::slime-connection)))

(defmethod swank-remote-call ((client swank-client) command-string)
  "Remote evaluate the LISP form in the string"
  (destructuring-bind (mode values)
                      ;; see also swank::eval-region as alternative!
                      (let ((sexp `(swank::listener-eval ,command-string)))
                        (swank-client::slime-eval sexp (swank-client-package client)))
    (ecase mode 
      (:present
       (apply #'values (mapcar (lambda (result)
                                 (make-remote-object :value (car result))) values))))))

(defmethod swank-client-dispatch ((client swank-client) command &rest args)
  NIL)

(defmacro define-swank-dispatch (event target (&rest arglist) &body body &aux (command (gensym))(args (gensym)))
  `(defmethod swank-client-dispatch ((,target ,target) (,command (eql ,event)) &rest ,args)
     (declare (ignore ,command) 
              (dynamic-extent ,args))
     (destructuring-bind ,arglist ,args
       ,@body)))

(advise swank-client::slime-dispatch-event
        (destructuring-bind (event &optional process) arglist          
          (let ((client (when process (gethash process *stream->swank-client*))))
            (if client
              (or 
               (let ((swank-client::slime-dispatching-connection 
                      (or process (swank-client::slime-connection))))
                 (apply #'swank-client-dispatch client event))
               (:do-it))
              (:do-it))))
        :when :around :name redirect-slime-dispatch-event)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SWANK LISTENER

(defclass swank-listener (listener swank-client)
  ())

(defmethod window-close :after ((listener swank-listener))
  (with-slots (connection) listener
    (swank-client::slime-net-close connection)))

(defmethod swank-client-package ((client window))
  (view-package-string client))

(defmethod read-user-input ((listener swank-listener))
  "Reads input from user as a string (called after user type enter)"
  (let* ((buffer (fred-buffer listener))
         (pos (buffer-position (listener-read-mark listener))))
    (multiple-value-bind (b e) 
                         (buffer-current-sexp-bounds buffer pos)
      (set-mark (listener-read-mark listener) e)
      (when e
        (buffer-substring buffer b e)))))

(defmethod read-remote-eval ((listener swank-listener))
  "Reads an expression from the listener and returns it in a form for remote evaluation"
  (let ((exp-string (read-user-input listener)))
    `(swank-remote-call ,listener ,exp-string)))

(defmethod stream-read ((listener swank-listener) eof-error-p eof-val)
  "Patches into the MCL read-loop-internal and toplevel-read"
  (if *listener-p*
    (read-remote-eval listener)
    (call-next-method)))

#+ignore
(defmethod set-window-title :around ((listener swank-listener) title)
  (call-next-method listener
     (format NIL "~A (~A)" 
           title
           (handler-case
             #+ignore
             (swank-remote-call listener "(cl:lisp-implementation-type)")
             (swank-client::slime-eval `(cl:lisp-implementation-type))
             (error (c)
                    (report-condition c *debug-io*)
                    "Swank")))))

(defmethod initialize-window :around ((w swank-listener) &key PROCESS)
  (call-next-method)
  (set-window-title w
     (format NIL "~A (~A)" 
           (window-title w)
           (handler-case
             #+ignore
             (swank-remote-call listener "(cl:lisp-implementation-type)")
             (swank-client::slime-eval `(cl:lisp-implementation-type))
             (error (c)
                    (report-condition c *debug-io*)
                    "Swank")))))
 
(defmethod view-package-string :around ((w fred-window))
  (if (remote-lisp-mode)
    (handler-case ;; ## need better way to not cause assertion failure before connection!
      (swank-client::slime-current-package (swank-client::slime-connection))
      (error (c)
             (values (call-next-method) c)))
    (call-next-method)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RPC

(defmethod remote-execute (command-string)
  (let ((listener (first (windows :class 'swank-listener))))
    (assert listener)
    (eval-enqueue  
     `(funcall
       ,#'(lambda ()
            (write (swank-remote-call listener command-string) :stream listener))))))

(defun remote-call (command-string)
  "Calls with a string, returns results as remote objects"
  (let ((listener (first (windows :class 'swank-listener))))
    (swank-remote-call listener command-string)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SWANK DISPATCH
;;
;; All communication both to and from the Swank server goes through the dispatch below.
;; Should return NIL for default event handling in swank-client.lisp, or non-nil if the event is fully processed.

(define-swank-dispatch :write-string swank-listener (output &optional mode)
  (write-string (substitute #\newline #\linefeed output) swank-listener)
  T)

(define-swank-dispatch :read-output swank-listener (output)
  T)

(define-swank-dispatch :presentation-start swank-listener (id)
  T)

(define-swank-dispatch :presentation-end swank-listener (id)
  T)

(define-swank-dispatch :emacs-rex swank-listener (form package thread continuation)
  NIL)

(define-swank-dispatch :return swank-listener (value id)
  NIL)

(define-swank-dispatch :debug-activate swank-listener (thread level)
  (setf *break-level* level)
  T)

(define-condition swank-condition (simple-condition) ())

(define-swank-dispatch :debug swank-listener (thread level condition restarts frames conts)
  (format swank-listener "ENTER DEBUG - ~A~%~S~%BACKTRACE:~%" (car condition) (cdr condition)) 
  (dolist (item frames)
    (format swank-listener "~A~%" item))
  (let ((%restarts%
         (flet ((build-restart (restart n)
                  (destructuring-bind (name description) restart
                    (make-restart NIL 
                                  (intern name :keyword) ; consider gensym...
                                  (lambda (&rest rest)
                                    (swank-client::slime-eval ; -async
                                     `(swank::invoke-nth-restart-for-emacs ,level ,n) 
                                     #+ignore
                                     `(let ((restart (cl:find-restart (cl:intern ,name))))
                                        (cl:invoke-restart restart)))
                                    #+ignore
                                    (return-from swank-client-dispatch T))
                                  :report-function 
                                  (lambda (out)(format out "~A (Swank)" description))))))
           (cons (loop for n from 0
                       for restart in restarts
                       collect (build-restart restart n))
                 %restarts%))))
    (handler-case
      #+ignore ;; start of a more custom break loop, way to go?
      (let ((ccl::*backtrace-dialogs* (cons dialog *backtrace-dialogs*)))
        (format t "~&> Type Command-. to abort.~%")
        (read-loop level))
      (let ((ccl::*break-level* (1- level)))
        (break-loop (make-condition 'swank-condition 
                                    :format-string "~A"
                                    :format-arguments (cdr condition))
                    NIL
                    *backtrace-on-break*))
      #+ignore
      (cbreak-loop (car condition) 
                   "Continue"  
                   (make-condition 'swank-condition 
                                   :format-string "~A"
                                   :format-arguments (cdr condition))
                   
                   NIL)
      (swank-condition (c)
                       (format swank-listener "~%BREAK (~A)~%" c)
                       (swank-client::slime-eval-async '(swank::sldb-abort))
                       )))
  T)

(define-swank-dispatch :debug-return swank-listener (thread level stepping)
    (setf *break-level* level)
    T)

(define-swank-dispatch :emacs-interrupt swank-listener (thread)
  T)

(define-swank-dispatch :read-string swank-listener (thread tag)
  (flet ((swank-return-string ()
           "Send a command string to swank"
           (let (string) 
             (unwind-protect
               (setf string
                     (third ; of the result from read-remote-eval
                      (let ((ccl::*top-listener* swank-listener))
                        ;; shouldn't prompt, but toplevel-read does that...
                        (toplevel-read))))
               (swank-client::slime-dispatch-event
                (if string  
                  `(:emacs-return ,thread ,tag ,(concatenate 'string 
                                                             string
                                                             (string #\linefeed)))
                  `(:emacs-interrupt ,thread)))
               (unless string
                 (warn "Interupted while reading input")
                 (swank-client::slime-reset)))
             #+ignore
             (swank-client::slime-dispatch-event `(:return-string ,thread ,tag ,string)))))
    (swank-return-string))
  T)

(define-swank-dispatch :evaluate-in-emacs swank-listener (thread tag)
  T)

(define-swank-dispatch :read-aborted swank-listener (thread tag)
  T)

(define-swank-dispatch :emacs-return-string swank-listener (thread tag string)
  NIL)

(define-swank-dispatch :new-package swank-listener (package prompt-string)
  #+ignore   ;; package as list allows use of string!
  (set-window-package (fred-item swank-listener) (list package))
  (setf (swank-client::slime-lisp-package) package)
  (setf (swank-client::slime-current-package) package)
  (setf (swank-client::slime-lisp-package-prompt-string) prompt-string)
  (eval-enqueue `(update-package-indicator ,swank-listener))
  T)

(define-swank-dispatch :new-features swank-listener (features)
  NIL)

(define-swank-dispatch :indentation-update swank-listener (info)
  T)

(define-swank-dispatch :open-dedicated-output-stream swank-listener (port)
  T)

(define-swank-dispatch :eval-no-wait swank-listener (fun args)
  T)

(define-swank-dispatch :eval swank-listener (thread tag fun args)
  T)

(define-swank-dispatch :emacs-return swank-listener (thread tag value)
  NIL)

(define-swank-dispatch :ed swank-listener (what)
  T)

(define-swank-dispatch :debug-condition swank-listener (thread message)
  T)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PACKAGES

(defun make-package-items-from-names (names &optional default action)
  (let ((items (sort (mapcar (lambda (p) (make-menu-item p action)) names)
                     (lambda (a b)
                       (string<= (menu-item-title a)(menu-item-title b))))))
    (if default (rplacd (last items) 
                        (list (make-menu-item (if (stringp default) default "All Packages") action))))
    items))

(defun remote-package-names ()
  (swank-client::slime-eval `(cl:mapcar #'cl:package-name (cl:list-all-packages))))

(defun remote-package-name ()
  "The name of the current package in the remote LISP (should always be the same as cl:*package*)"
  (swank-client::slime-current-package (swank-client::slime-connection)))

(defun set-remote-package (name)
  ;; will trigger a :new-package callback!
  ;; Note that it cannot return a package as it is an unreadable!
  #+ignore ; setting *package* won't have a :new-package callback if in a progn
  (swank-client::slime-eval `(progn (cl:setq cl:*package* (cl:find-package ,name)) ,name))
  (swank-client::slime-eval 
   `(swank::listener-eval 
     ,(format NIL "(cl:setq cl:*package* (cl:find-package ~S))" name))))

(defun make-remote-package-items (&optional all action)
  "Replicates make-package-items but on the remote lisp"
  (let* ((ps (remote-package-names)))
    (make-package-items-from-names ps all action)))

(advise make-package-items
        (if (remote-lisp-mode)
          (apply #'make-remote-package-items arglist)
          (:do-it))       
        :when :around :name swank-make-package-items)

(defun menu-select-remote-package (menu)
  (let* ((pn (remote-package-name))
         (item (when pn (find-menu-item menu pn)))
         (p (when item (menu-item-number item)))) 
    (when p (set-pop-up-menu-default-item menu p))))

(defun string-name-package (name)
  "Split a symbol encoded as a string into name and package strings"
  ; like ccl::string-package-and-tail
  (let ((pos (position #\: name))
        (pkg))
    (when pos
      (setq pkg
            (if (eq pos 0) 
              "KEYWORD"
              (string-upcase (subseq name 0 pos)))))
    (when pkg
      (setq name
            (subseq name (1+ (if (eq #\: (schar name (1+ pos))) (1+ pos) pos)))))
    (values name pkg)))

; (string-name-package "CCL::test")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SWANK AWARE FRED

(defmethod window-enqueue-region :around ((w fred-mixin) start end 
                                          &optional mini-str single-selection? evalp)
  (declare (ignore mini-str single-selection? evalp))
  (handler-case
    (let ((listener (front-window :class *default-listener-class*)))
      (typecase listener
        (swank-listener  
         (eval-enqueue  
          `(funcall
            ,#'(lambda ()
                 (let* ((command-string (buffer-substring (fred-buffer w) start end)))
                   (dolist (item (multiple-value-list 
                                  (swank-remote-call listener command-string)))
                     (print item listener)))))))
        (otherwise 
         (call-next-method))))
    (error (c)
           (warn "~A" c)
           (call-next-method))))

;; (values 1 2)
;; (make-instance 'ccl::swank-listener :port 51007)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; APROPOS DIALOG

(advise apropos-dialog
        (let ((d (front-window :class 'apropos-dialog)))
          (:do-it)
          (unless d
            (setf d (front-window :class 'apropos-dialog))
            (let* ((sub (subviews d 'pop-up-menu))
                   (package-menu (second sub))
                   (update-function (menu-update-function package-menu)))
              (setf (menu-update-function package-menu)
                    (lambda (menu)
                      (if (remote-lisp-mode)
                        (let ((pnms (remote-package-names)))
                          (when (set-exclusive-or pnms (view-get (view-container menu) :packages) :test #'equal)
                            (replace-menu-items menu (make-package-items-from-names pnms t)) 
                            (view-put d :packages pnms)))
                        (funcall update-function menu))))
              d))
          (when (remote-lisp-mode)
            (menu-select-remote-package (view-named 'package d))))
        :when :around :name :swank-apropos-dialog)

(defun remote-apropos-search (d) 
  ;; ## incomplete, need to be able to limit result to external symbols!!!
  (let* ((pt (menu-item-title (selected-item (view-named 'package d))))
         (pname (unless (equal pt "All Packages") pt))
         (pk (find-package pname))
         (str1 (dialog-item-text (view-named 'string1 d)))
         (str1-p (not (equal "" str1)))
         (str2 (dialog-item-text (view-named 'string2 d)))
         (str2-p (not (equal "" str2)))
         (type (nth (1- (pop-up-menu-default-item (view-named 'type d)))
                    *apropos-types*))
         (op (nth (1- (pop-up-menu-default-item (view-named 'operation d))) 
                    '(:and :or :not)))
         (external (check-box-checked-p (view-named 'external d)))
         (result (swank-client::slime-eval 
                   `(let* ((items1 ,(when str1-p `(apropos-list ,str1 ,pname)))
                           (items2 ,(when str2-p `(apropos-list ,str2 ,pname)))
                           (result
                           ,(ecase op
                              (:and 
                               (if (and str1-p str2-p) 
                                 `(cl:intersection items1 items2)
                                 `(or items1 items2)))
                              (:or
                               `(cl:union items1 items2))
                              (:not 
                               (if str2-p 
                                 `(cl:set-difference items1 items2)
                                 `items1)))))
                      (mapcar #'string 
                              (remove-if-not
                               ,(case type
                                  (function `#'fboundp)
                                  (variable `#'boundp)
                                  (ccl::macro `#'macro-function)
                                  (class `#'(lambda (sym)(find-class sym nil)))
                                  (T `#'true))
                               result)))
                   "COMMON-LISP"))
         (table (view-named 'table d)))
    (set-table-sequence table 
                        (mapcar (lambda (name)                                
                                  (or 
                                   (when pk (find-symbol name pk))
                                   (make-symbol name)))
                                result))))

(defmethod apropos-search :around (button)
  (if (remote-lisp-mode)
    (remote-apropos-search (view-window button))
    (call-next-method)))

(advise apropos-update
       (if (remote-lisp-mode)
         (destructuring-bind (button type) arglist
           (let* ((d (view-window button))
                  (thing (thing-name-from-dialog d)))
             (if (and thing (member type '(:inspect :doc)))
               (dialog-item-enable button)
               (dialog-item-disable button))))
         (:do-it))
       :when :around :name :swank-apropos-update)

(advise do-apropos
       (if (remote-lisp-mode)
         (destructuring-bind (item what) arglist
           (:do-it))
         (:do-it))
       :when :around :name :swank-do-apropos)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TRACE DIALOG

(defun remote-untrace (symbol-name package-name)
  (remote-call (format NIL "(cl:untrace ~A::~A)" package-name symbol-name))) 

(defun remote-trace (symbol-name package-name)
  (remote-call (format NIL "(cl:trace ~A::~A)" package-name symbol-name))) 

(defun remote-traced ()
  "List of remotely traced symbols (as strings)"
  (swank-client::slime-eval `(cl:mapcar #'cl:prin1-to-string (cl:trace))))
    
(advise do-trace
       (if (remote-lisp-mode)
         (destructuring-bind (dialog &optional untrace) arglist
           (let ((name (dialog-item-text (view-named 'search-text-item dialog)))
                 (pnm (menu-item-title (selected-item (view-named 'package dialog))))
                 (out (fred-item (view-named 'result dialog))))
             (set-dialog-item-text out "")
             (prin1
              (if untrace
                (remote-untrace name pnm)
                (remote-trace name pnm))
              out)
             (force-output out)))
         (:do-it))
       :when :around :name :swank-do-trace)

(advise update-untrace-menu
       (if (remote-lisp-mode)
         (destructuring-bind (menu) arglist
           (apply #'remove-menu-items menu (cddr (menu-items menu)))
           (apply #'add-menu-items menu
                               (mapcar 
                                (lambda (name)
                                  (make-menu-item name
                                                  (lambda ()
                                                    (multiple-value-call 
                                                     #'remote-untrace
                                                     (string-name-package name)))))                                                          
                               (remote-traced))))
         (:do-it))
       :when :around :name :swank-update-untrace-menu)

(advise trace-dialog
        (when (remote-lisp-mode)
          (menu-select-remote-package (view-named 'package (front-window :class 'trace-dialog))))
       :when :after :name :remote-trace-dialog)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MODERN PACKAGE INDICATOR
;;
;; Compatability with <http://www.in-progress.com/src/fred-package-indicator.lisp>,
;; which adds a neat package pop-up menu to Fred and the MCL Listener.

(defmethod update-package-indicator (w &optional pkg-str)
  (declare (ignore w pkg-str))
  NIL)

(defmethod update-package-indicator :around ((w fred-window) &optional (pkg-str (view-package-string w)))
  (let* ((view (view-container (view-mini-buffer w)))
         (package-indicator (view-named 'package-indicator view)))
      (call-next-method)
      (unless (or package-indicator
                  (not (setf package-indicator (view-named 'package-indicator view))))
        (let* ((menu (slot-value package-indicator 'menu))
               (update-function (menu-update-function menu)))
          (setf (menu-update-function menu)
              (lambda (menu)
                (if (remote-lisp-mode)
                  (let ((packages (sort (remote-package-names) #'string<)))
                    ; replace-menu-items doesn't work well here...
                    (apply #'remove-menu-items menu (menu-items menu))
                    (apply #'add-menu-items menu
                           (mapcar 
                            (lambda (name)
                              (make-menu-item name
                                              (lambda ()
                                               (handler-case
                                                 (set-remote-package name)
                                                 (error (c)
                                                        (format *debug-io* "~A" c))))))
                            packages))
                    (let ((pos (position (view-package-string (view-window menu)) packages
                                         :test #'string-equal)))
                      (when pos ; nil if the package of the document isn't yet defined.
                        (set-pop-up-menu-default-item menu (1+ pos)))))
                  (funcall update-function menu))))
        menu))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PACKAGES INSPECTOR

(defun inspect-remote-packages ()
  (inspector::inspect-object
   (remote-package-names))) 

(let* ((menu (find-menu-item *tools-menu* "Inspector")))
  (let* ((item (find-menu-item menu "Packages"))
        (action (menu-item-action-function item)))
    (set-menu-item-action-function 
     item
     (lambda ()
       (if (remote-lisp-mode)
         (inspect-remote-packages)
         (funcall action)))))
  (let* ((item (find-menu-item menu "*package*"))
        (action (menu-item-action-function item)))
    (set-menu-item-action-function 
     item
     (lambda ()
       (if (remote-lisp-mode)
         (inspector::inspect-object (remote-package-name))
         (funcall action))))))