Permalink
Browse files

ASDF commands for the listener.

  • Loading branch information...
1 parent 955150d commit 93610d6e011754d33ba4bf6313422feae5a8efd7 Andy Hefner committed Jun 7, 2009
Showing with 168 additions and 16 deletions.
  1. +152 −0 Apps/Listener/asdf.lisp
  2. +3 −7 Apps/Listener/dev-commands.lisp
  3. +9 −5 Apps/Listener/listener.lisp
  4. +4 −4 Apps/Listener/package.lisp
@@ -0,0 +1,152 @@
+;;; 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)))
@@ -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 @@ if you are interested in fixing this."))
"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
@@ -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
@@ -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*)))))

0 comments on commit 93610d6

Please sign in to comment.