Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory cl-net:/tmp/cvs-serv32228

Modified Files: dev-commands.lisp listener.lisp package.lisp Added Files: asdf.lisp Log Message: ASDF commands for the listener.

--- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2009/04/14 07:36:42 1.66 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2009/06/07 08:47:39 1.67 @@ -24,7 +24,9 @@ (define-command-table application-commands)

(define-command-table lisp-dev-commands :inherit-from nil) ;; Translators live here -(define-command-table lisp-commands :inherit-from (lisp-dev-commands)) +(define-command-table lisp-commands + :inherit-from (lisp-dev-commands) + :menu (("ASDF" :menu asdf-commands)))

(define-command-table show-commands :inherit-from (lisp-dev-commands))

@@ -34,7 +36,6 @@

(define-command-table directory-stack-commands)

- ;;; Presentation types

(define-presentation-type specializer () :inherit-from 'expression) @@ -1241,11 +1242,6 @@ "Load" (format nil "Load ~A" pathname)))

-(defmethod mime-type-to-command ((mime-type text/x-lisp-system) pathname) - (values `(com-load-file ,pathname) - "Load System" - (format nil "Load System ~A" pathname))) - ;; I've taken to doing translator documentation exactly opposite of how the CLIM ;; spec seems to intend. The spec says that the pointer-documentation should be ;; short and quickly computed, and the documentation should be longer and more --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/12/07 20:24:44 1.44 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2009/06/07 08:47:40 1.45 @@ -96,11 +96,15 @@ :display-time :command-loop :end-of-line-action :allow))) (:top-level (default-frame-top-level :prompt 'print-listener-prompt)) (:command-table (listener - :inherit-from (application-commands lisp-commands filesystem-commands show-commands) - :menu (("Application" :menu application-commands) - ("Lisp" :menu lisp-commands) - ("Filesystem" :menu filesystem-commands) - ("Show" :menu show-commands)))) + :inherit-from (application-commands + lisp-commands + asdf-commands + filesystem-commands + show-commands) + :menu (("Listener" :menu application-commands) + ("Lisp" :menu lisp-commands) + ("Filesystem" :menu filesystem-commands) + ("Show" :menu show-commands)))) (:disabled-commands com-pop-directory com-drop-directory com-swap-directory) (:menu-bar t) (:layouts (default --- /project/mcclim/cvsroot/mcclim/Apps/Listener/package.lisp 2008/04/26 21:19:59 1.4 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/package.lisp 2009/06/07 08:47:40 1.5 @@ -8,7 +8,7 @@ (in-package :clim-listener)

(eval-when (:load-toplevel) -; (format t "~&~%!@#%^!@#!@ ... ~A~%~%" *load-truename*) - (defparameter *icon-path* (merge-pathnames - #P"icons/" - (load-time-value (or #.*compile-file-pathname* *load-pathname*))))) + (defparameter *icon-path* + (merge-pathnames + #P"icons/" + (load-time-value (or #.*compile-file-pathname* *load-pathname*)))))

--- /project/mcclim/cvsroot/mcclim/Apps/Listener/asdf.lisp 2009/06/07 08:47:43 NONE +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/asdf.lisp 2009/06/07 08:47:43 1.1 ;;; This is a lisp listener.

;;; (C) Copyright 2009 by Andy Hefner (ahefner@gmail.com)

;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library 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. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.

(in-package :clim-listener)

;;;; CLIM defintions for interacting with ASDF

(define-command-table asdf-commands :inherit-from nil)

(define-presentation-type asdf-system ()) (define-presentation-type asdf-system-definition () :inherit-from 'pathname)

(defclass asdf-attribute-view (textual-view) ((ignorable-attributes :reader ignorable-attributes :initform nil :initarg :ignore) (note-unloaded :reader note-unloaded :initform nil :initarg :note-unloaded) (default-label :reader default-attr-label :initform "" :initarg :default)))

(defmethod ignorable-attributes (view) nil) (defmethod note-unloaded (view) nil) (defmethod default-attr-label (view) "")

(defun asdf-loaded-systems () "Retrieve a list of loaded systems from ASDF" (let (systems) (maphash (lambda (name foo.system) (declare (ignore name)) (push (cdr foo.system) systems)) asdf::*defined-systems*) systems))

(defun asdf-get-central-registry () asdf::*central-registry*)

(defun asdf-registry-system-files () "Retrieve the list of unique pathnames contained within the ASDF registry folders" (remove-duplicates (remove-if-not #'pathname-name (apply #'concatenate 'list (mapcar (lambda (form) (list-directory (merge-pathnames (eval form) #p"*.asd"))) (asdf-get-central-registry)))) :test #'equal))

(defun asdf-system-name (system) (slot-value system 'asdf::name))

(defun asdf-operation-pretty-name (op) (case op (asdf:compile-op "compiled") (asdf:load-op "loaded") (:unloaded "unloaded") (otherwise (prin1-to-string op))))

(defun asdf-system-history (system) (let (history) (maphash (lambda (operation time) (declare (ignore time)) (push operation history)) (slot-value system 'asdf::operation-times)) (nreverse history)))

(define-presentation-method presentation-typep (object (type asdf-system)) (typep object 'asdf:system))

(define-presentation-method present (object (type asdf-system) stream (view textual-view) &key acceptably) (if acceptably (princ (asdf-system-name object) stream ) (let* ((history (asdf-system-history object)) (loaded-p (find 'asdf:load-op history)) (eff-history (set-difference history (ignorable-attributes view)))) (when (and (note-unloaded view) (not loaded-p)) (push :unloaded eff-history)) (format stream "~A~A" (asdf-system-name object) (if (null eff-history) (default-attr-label view) (format nil " (~{~a~^, ~})" (mapcar 'asdf-operation-pretty-name eff-history)))))))

(define-presentation-method accept ((type asdf-system) stream (view textual-view) &key) (multiple-value-bind (object success) (completing-from-suggestions (stream) (dolist (system (asdf-loaded-systems)) (suggest (asdf-system-name system) system))) (if success object (simple-parse-error "Unknown system"))))

(define-command (com-list-systems :name "List Systems" :command-table asdf-commands :menu t) () (format-items (asdf-loaded-systems) :printer (lambda (item stream) (present item 'asdf-system :stream stream :view (make-instance 'asdf-attribute-view :note-unloaded t :ignore '(asdf:compile-op asdf:load-op)))) :presentation-type 'asdf-system))

(define-command (com-show-available-systems :name "Show System Files" :command-table asdf-commands :menu t) () (format-items (asdf-registry-system-files) :presentation-type 'asdf-system-definition))

(define-command (com-operate-on-system :name "Operate On System" :command-table asdf-commands :menu t) ((system '(type-or-string asdf-system) :prompt "system") (operation '(member asdf::compile-op asdf::load-op) :default 'asdf::load-op :prompt "operation")) (asdf:oos operation system))

(define-command (com-load-system :name "Load System" :command-table asdf-commands :menu t) ((system '(type-or-string asdf-system) :prompt "system")) (asdf:oos 'asdf:compile-op system) (asdf:oos 'asdf:load-op system))

(defmethod mime-type-to-command ((mime-type text/x-lisp-system) pathname) (values `(com-load-system ,pathname) "Load System" (format nil "Load System ~A" pathname)))