[mcclim-cvs] CVS mcclim/Apps/Listener
ahefner
ahefner at common-lisp.net
Sun Jun 7 08:47:43 UTC 2009
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 at 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)))
More information about the Mcclim-cvs
mailing list