[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Wed Sep 6 20:07:22 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv26720
Modified Files:
search-commands.lisp packages.lisp misc-commands.lisp gui.lisp
core.lisp climacs.asd
Added Files:
groups.lisp
Log Message:
Added Group functionality to Climacs (the additions to the User Manual
was erroneously part of my previous commit). Needs testing and better
support from search/replace commands.
--- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/08/20 13:06:38 1.13
+++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/09/06 20:07:21 1.14
@@ -317,15 +317,19 @@
(with-accessors ((string string1)
(buffers buffers)
(mark mark)) state
- (let ((offset-before (offset mark)))
- (search-forward mark string :test (case-relevant-test string))
- (or (/= (offset mark) offset-before)
- (unless (null (rest buffers))
- (pop buffers)
- (switch-to-buffer (first buffers))
- (setf mark (point (first buffers)))
- (beginning-of-buffer mark)
- (query-replace-find-next-match state))))))
+ (flet ((head-to-buffer (buffer)
+ (switch-to-buffer buffer)
+ (setf mark (point (current-window)))
+ (beginning-of-buffer mark)))
+ (unless (eq (current-buffer) (first buffers))
+ (when t buffers
+ (head-to-buffer (first buffers))))
+ (let ((offset-before (offset mark)))
+ (search-forward mark string :test (case-relevant-test string))
+ (or (/= (offset mark) offset-before)
+ (unless (null (rest buffers))
+ (pop buffers)
+ (query-replace-find-next-match state)))))))
(define-command (com-query-replace :name t :command-table search-table) ()
(let* ((pane (current-window))
@@ -357,19 +361,20 @@
(point (point pane))
(occurrences 0))
(declare (special string1 string2 occurrences))
- (setf (query-replace-state pane) (make-instance 'query-replace-state
- :string1 string1
- :string2 string2
- :mark point
- :buffers (list (buffer pane))))
- (when (query-replace-find-next-match (query-replace-state pane))
- (setf (query-replace-mode pane) t)
- (display-message "Replace ~A with ~A:"
- string1 string2)
- (simple-command-loop 'query-replace-climacs-table
- (query-replace-mode pane)
- ((setf (query-replace-mode pane) nil))))
- (display-message "Replaced ~A occurrence~:P" occurrences)))
+ (with-group-buffers (buffers (get-active-group))
+ (setf (query-replace-state pane) (make-instance 'query-replace-state
+ :string1 string1
+ :string2 string2
+ :mark point
+ :buffers buffers))
+ (when (query-replace-find-next-match (query-replace-state pane))
+ (setf (query-replace-mode pane) t)
+ (display-message "Replace ~A with ~A:"
+ string1 string2)
+ (simple-command-loop 'query-replace-climacs-table
+ (query-replace-mode pane)
+ ((setf (query-replace-mode pane) nil))))
+ (display-message "Replaced ~A occurrence~:P" occurrences))))
(set-key 'com-query-replace
'search-table
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/04 09:00:30 1.116
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/06 20:07:21 1.117
@@ -340,6 +340,8 @@
#:syntax
#:mark
#:buffers
+ #:active-group
+ #:groups
#:insert-character
#:display-window
#:split-window
@@ -430,7 +432,23 @@
#:open-rectangle-line
#:replace-rectangle-line
#:insert-in-rectangle-line
- #:delete-rectangle-line-whitespace)
+ #:delete-rectangle-line-whitespace
+
+ #:group
+ #:group-element
+ #:standard-group
+ #:current-buffer-group
+ #:add-group
+ #:get-group
+ #:get-active-group
+ #:deselect-group
+ #:with-group-buffers
+ #:define-group
+ #:group-not-found
+ #:group-buffers
+ #:ensure-group-buffers
+ #:select-group
+ #:display-group-contents)
(:documentation "Package for editor functionality that is
syntax-aware, but yet not specific to certain
syntaxes. Contains stuff like indentation, filling and other
--- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/09/04 09:00:30 1.24
+++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/09/06 20:07:21 1.25
@@ -756,6 +756,10 @@
"Toggle the visibility of the region in the current pane."
(setf (region-visible-p (current-window)) (not (region-visible-p (current-window)))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Rectangle editing
+
(define-command (com-kill-rectangle :name t :command-table deletion-table)
()
"Kill the rectangle bounded by current point and mark.
@@ -860,3 +864,68 @@
#'delete-rectangle-line-whitespace
(current-point)
(current-mark)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Groups
+
+(define-command (com-define-group :name t :command-table global-climacs-table)
+ ((name 'string :prompt "Name")
+ (buffers '(sequence climacs-buffer) :prompt "Buffers"))
+ (when (or (not (get-group name))
+ (accept 'boolean :prompt "Group already exists. Overwrite existing group?"))
+ (add-group name buffers))
+ (select-group (get-group name)))
+
+(set-key `(com-define-group ,*unsupplied-argument-marker* ,*unsupplied-argument-marker*)
+ 'global-climacs-table
+ '((#\x :control) (#\g) (#\d)))
+
+(define-command (com-define-file-group :name t :command-table global-climacs-table)
+ ((name 'string :prompt "Name")
+ (pathnames '(sequence pathname) :prompt "Files"))
+ (when (or (not (get-group name))
+ (accept 'boolean :prompt "Group already exists. Overwrite existing group?"))
+ (add-group name pathnames))
+ (select-group (get-group name)))
+
+(set-key `(com-define-file-group ,*unsupplied-argument-marker* ,*unsupplied-argument-marker*)
+ 'global-climacs-table
+ '((#\x :control) (#\g) (#\f)))
+
+(define-command (com-select-group :name t :command-table global-climacs-table)
+ ((group 'group))
+ (select-group group))
+
+(set-key `(com-select-group ,*unsupplied-argument-marker*)
+ 'global-climacs-table
+ '((#\x :control) (#\g) (#\s)))
+
+(define-command (com-deselect-group :name t :command-table global-climacs-table)
+ ()
+ (deselect-group)
+ (display-message "Group deselected"))
+
+(set-key 'com-deselect-group
+ 'global-climacs-table
+ '((#\x :control) (#\g) (#\u)))
+
+(define-command (com-current-group :name t :command-table global-climacs-table)
+ ()
+ (with-minibuffer-stream (s)
+ (format s "Active group is: ")
+ (present (get-active-group) 'group :stream s)))
+
+(set-key 'com-current-group
+ 'global-climacs-table
+ '((#\x :control) (#\g) (#\c)))
+
+(define-command (com-list-group-contents :name t :command-table global-climacs-table)
+ ()
+ (with-minibuffer-stream (s)
+ (format s "Active group designates: ")
+ (display-group-contents (get-active-group) s)))
+
+(set-key 'com-list-group-contents
+ 'global-climacs-table
+ '((#\x :control) (#\g) (#\l)))
\ No newline at end of file
--- /project/climacs/cvsroot/climacs/gui.lisp 2006/09/03 21:23:29 1.229
+++ /project/climacs/cvsroot/climacs/gui.lisp 2006/09/06 20:07:21 1.230
@@ -130,6 +130,8 @@
(define-application-frame climacs (standard-application-frame
esa-frame-mixin)
((buffers :initform '() :accessor buffers)
+ (groups :initform (make-hash-table :test #'equal) :accessor groups)
+ (active-group :initform nil :accessor active-group)
(kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring))
(:command-table (global-climacs-table
:inherit-from (global-esa-table
--- /project/climacs/cvsroot/climacs/core.lisp 2006/09/02 21:43:56 1.7
+++ /project/climacs/cvsroot/climacs/core.lisp 2006/09/06 20:07:21 1.8
@@ -596,6 +596,33 @@
(and (or (null name) (eql name :unspecific))
(or (null type) (eql type :unspecific)))))
+(defun findablep (pathname)
+ "Return non-NIL if `pathname' can be opened by Climacs. That
+ is, check whether the file exists and is not a directory."
+ (and (probe-file pathname)
+ (not (directory-pathname-p pathname))))
+
+(defun find-buffer-with-pathname (pathname)
+ "Return the (first) buffer associated with the file designated
+by `pathname'. Returns NIL if no buffer can be found."
+ (flet ((usable-pathname (pathname)
+ (if (probe-file pathname)
+ (truename pathname)
+ pathname)))
+ (find pathname (buffers *application-frame*)
+ :key #'filepath
+ :test #'(lambda (fp1 fp2)
+ (and fp1 fp2
+ (equal (usable-pathname fp1)
+ (usable-pathname fp2)))))))
+
+(defun ensure-open-file (pathname)
+ "Make sure a buffer opened on `pathname' exists, finding the
+file if necessary."
+ (when (and (findablep pathname)
+ (not (find-buffer-with-pathname pathname)))
+ (find-file pathname *application-frame*)))
+
(defun find-file-impl (filepath &optional readonlyp)
(cond ((null filepath)
(display-message "No file name given.")
@@ -604,42 +631,33 @@
(display-message "~A is a directory name." filepath)
(beep))
(t
- (flet ((usable-pathname (pathname)
- (if (probe-file pathname)
- (truename pathname)
- pathname)))
- (let ((existing-buffer (find filepath (buffers *application-frame*)
- :key #'filepath
- :test #'(lambda (fp1 fp2)
- (and fp1 fp2
- (equal (usable-pathname fp1)
- (usable-pathname fp2)))))))
- (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t))
- (switch-to-buffer existing-buffer)
- (progn
- (when readonlyp
- (unless (probe-file filepath)
- (beep)
- (display-message "No such file: ~A" filepath)
- (return-from find-file-impl nil)))
- (let ((buffer (if (probe-file filepath)
- (with-open-file (stream filepath :direction :input)
- (make-buffer-from-stream stream *application-frame*))
- (make-new-buffer *application-frame*)))
- (pane (current-window)))
- (setf (offset (point (buffer pane))) (offset (point pane))
- (buffer (current-window)) buffer
- (syntax buffer) (make-instance (syntax-class-name-for-filepath filepath)
- :buffer buffer)
- (file-write-time buffer) (file-write-date filepath))
- (evaluate-attribute-line buffer)
- (setf (filepath buffer) filepath
- (name buffer) (filepath-filename filepath)
- (read-only-p buffer) readonlyp)
- (beginning-of-buffer (point pane))
- (update-syntax buffer (syntax buffer))
- (clear-modify buffer)
- buffer))))))))
+ (let ((existing-buffer (find-buffer-with-pathname filepath)))
+ (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t))
+ (switch-to-buffer existing-buffer)
+ (progn
+ (when readonlyp
+ (unless (probe-file filepath)
+ (beep)
+ (display-message "No such file: ~A" filepath)
+ (return-from find-file-impl nil)))
+ (let ((buffer (if (probe-file filepath)
+ (with-open-file (stream filepath :direction :input)
+ (make-buffer-from-stream stream *application-frame*))
+ (make-new-buffer *application-frame*)))
+ (pane (current-window)))
+ (setf (offset (point (buffer pane))) (offset (point pane))
+ (buffer (current-window)) buffer
+ (syntax buffer) (make-instance (syntax-class-name-for-filepath filepath)
+ :buffer buffer)
+ (file-write-time buffer) (file-write-date filepath))
+ (evaluate-attribute-line buffer)
+ (setf (filepath buffer) filepath
+ (name buffer) (filepath-filename filepath)
+ (read-only-p buffer) readonlyp)
+ (beginning-of-buffer (point pane))
+ (update-syntax buffer (syntax buffer))
+ (clear-modify buffer)
+ buffer)))))))
(defmethod find-file (filepath (application-frame climacs))
(find-file-impl filepath nil))
--- /project/climacs/cvsroot/climacs/climacs.asd 2006/09/06 17:42:08 1.53
+++ /project/climacs/cvsroot/climacs/climacs.asd 2006/09/06 20:07:21 1.54
@@ -97,13 +97,14 @@
(:file "io" :depends-on ("packages" "gui"))
(:file "core" :depends-on ("gui"))
(:file "rectangle" :depends-on ("core"))
+ (:file "groups" :depends-on ("core"))
(:file "climacs" :depends-on ("gui" "core"))
;; (:file "buffer-commands" :depends-on ("gui"))
(:file "developer-commands" :depends-on ("gui" "lisp-syntax" "core"))
(:file "motion-commands" :depends-on ("gui" "core"))
(:file "editing-commands" :depends-on ("gui" "core"))
(:file "file-commands" :depends-on ("gui" "core"))
- (:file "misc-commands" :depends-on ("gui" "core" "rectangle"))
+ (:file "misc-commands" :depends-on ("gui" "core" "rectangle" "groups"))
(:file "search-commands" :depends-on ("gui" "core"))
(:file "window-commands" :depends-on ("gui" "core"))
(:file "unicode-commands" :depends-on ("gui" "core"))
--- /project/climacs/cvsroot/climacs/groups.lisp 2006/09/06 20:07:22 NONE
+++ /project/climacs/cvsroot/climacs/groups.lisp 2006/09/06 20:07:22 1.1
;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-
;;; (c) copyright 2006 by
;;; Troels Henriksen (athas at sigkill.dk)
;;; 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.
;;; Implementation of a groups concept.
(in-package :climacs-core)
(defvar *persistent-groups* (make-hash-table :test #'equal)
"A hash table of groups that are persistent across invocations
of the Climacs editor. Typically, these do not designate
concrete pathnames, but contain more abstract designations such
as \"all files in the current directory\".")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; File/Buffer group classes.
(defclass group (name-mixin)
())
(defclass group-element (group)
((%element :initarg :element :initform nil :reader element))
(:documentation "Group class denoting a single element"))
(defclass standard-group (group)
((%elements :initarg :elements :initform nil :reader elements))
(:documentation "Group class denoting a sequence of elements."))
(defclass current-buffer-group (group)
()
(:documentation "Group class denoting the currently active
buffer."))
(defclass synonym-group (group)
((%other-name :initarg :other-name
:initform (error "The name of another buffer must be provided")
:reader other-name))
(:documentation "Group class that forwards all methods to a
group with a specific name."))
(defclass custom-group (group)
((%list-pathnames-lambda
:initarg :pathname-lister
:initform (error "A custom group must have code for retrieving a list of pathnames")
:reader pathname-lister)
(%select-group-lambda
:initarg :select-response
:initform #'(lambda (&rest a)
(declare (ignore a)))
:reader select-response)
(%value-plist
:initform nil
:accessor value-plist))
(:documentation "A group that will call a provided function
when it is selected or asked for pathnames."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The group protocol.
(defgeneric group-buffers (group)
(:documentation "Get a list of buffers in `group'. Only already
existing buffers will be returned, use `ensure-group-buffers'
if you want all buffers defined by the group."))
(defgeneric ensure-group-buffers (group)
(:documentation "For each pathname in `group' that does not
have a corresponding buffer, open a buffer for that pathname."))
(defgeneric select-group (group)
(:documentation "Tell the group object `group' that the user
has selected it. This method is responsible for setting the
active group. If `group' needs additional information, it
should query the user when this method is invoked. The standard
method should be sufficient for most group classes.")
(:method ((group group))
;; Use a synonym group so that changes to the group of this name
;; will be reflected in the active group.
(setf (active-group *application-frame*)
(make-synonym-group group))))
(defgeneric display-group-contents (group stream)
(:documentation "Display the contents of `group' to
`stream'. Basically, this should describe which buffers or
files would be affected by group-aware commands if `group' was
the active group. There is no standard format for the output,
but it is intended for displaying to the user."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Protocol implementation.
;; Display helper functions.
(defun normalise-group-element (element)
"Turn `element' into either a pathname, an existing buffer or
NIL. If a pathname is returned, it is assumed to be safe to find
the file with that name."
(typecase element
(climacs-buffer
(find element (buffers *application-frame*)))
((or pathname string)
(or (find-buffer-with-pathname (pathname element))
(when (findablep element)
element)))
(group-element
(normalise-group-element (element element)))))
(defun display-group-element (element stream)
(let ((norm-element (normalise-group-element element)))
(typecase norm-element
(climacs-buffer
(present norm-element 'buffer stream))
((or pathname string)
(present norm-element 'pathname stream)))))
;; Singular group elements.
(defmethod group-buffers ((group group-element))
(let ((element (element group)))
(cond ((and (typep element 'climacs-buffer)
(find element (buffers *application-frame*)))
(list element))
((or (pathnamep element)
(stringp element))
(let ((buffer (find-buffer-with-pathname (pathname element))))
(when buffer (list buffer))))
(t '()))))
(defmethod ensure-group-buffers ((group group-element))
(typecase (element group)
(climacs-buffer
(unless (find (element group) (buffers *application-frame*))
(ensure-open-file (pathname (filepath (element group))))))
(pathname
(ensure-open-file (element group)))
(string
(ensure-open-file (pathname (element group))))))
(defmethod display-group-contents ((group group-element) (stream extended-output-stream))
(display-group-element (element group) stream))
;; Standard sequence groups.
(defmethod group-buffers ((group standard-group))
(apply #'append (mapcar #'group-buffers (elements group))))
(defmethod ensure-group-buffers ((group standard-group))
(mapcar #'ensure-group-buffers (elements group)))
(defmethod display-group-contents ((group standard-group) (stream extended-output-stream))
(present (remove-if #'null (mapcar #'normalise-group-element (elements group)))
'(sequence (or pathname buffer)) :stream stream))
;; The current buffer group (default).
(defmethod group-buffers ((group current-buffer-group))
(list (current-buffer)))
(defmethod ensure-group-buffers ((group current-buffer-group))
nil)
(defmethod display-group-contents ((group current-buffer-group) (stream extended-output-stream))
(display-group-element (current-buffer) stream))
;; Custom groups.
(defmethod group-buffers ((group custom-group))
(remove-if #'null (mapcar #'find-buffer-with-pathname (funcall (pathname-lister group) group))))
(defmethod ensure-group-buffers ((group custom-group))
(mapcar #'ensure-open-file (funcall (pathname-lister group) group)))
(defmethod select-group ((group custom-group))
(funcall (select-response group) group)
(setf (active-group *application-frame*) group))
(defmethod display-group-contents ((group custom-group) (stream extended-output-stream))
(present (remove-if #'null (mapcar #'normalise-group-element (funcall (pathname-lister group) group)))
'(sequence (or pathname buffer)) :stream stream))
;; Synonym groups.
(define-condition group-not-found (simple-error)
((%group-name :reader group-name
:initarg :group-name
:initform (error "A name for the group must be provided")))
(:report (lambda (condition stream)
(format stream "Group named ~a not found" (group-name condition))))
(:documentation "This condition is signaled whenever a synonym
group is unable to find the group that it is supposed to
forward method invocations to."))
(defmethod group-buffers ((group synonym-group))
(if (get-group (other-name group))
(group-buffers (get-group (other-name group)))
(error 'group-not-found :group-name (other-name group))))
(defmethod ensure-group-buffers ((group synonym-group))
(if (get-group (other-name group))
(ensure-group-buffers (get-group (other-name group)))
(error 'group-not-found :group-name (other-name group))))
(defmethod select-group ((group synonym-group))
(if (get-group (other-name group))
(select-group (get-group (other-name group)))
(error 'group-not-found :group-name (other-name group))))
(defmethod display-group-contents ((group synonym-group) stream)
(if (get-group (other-name group))
(display-group-contents (get-group (other-name group)) stream)
(error 'group-not-found :group-name (other-name group))))
;; Util stuff.
(defun make-synonym-group (group)
"Create and return a synonym group that refers to `group'. All
group protocol-specified methods called on the synonym group will
be forwarded to a group with the same name as `group'."
(make-instance 'synonym-group
:other-name (name group)
:name (name group)))
(defun make-group-element (object)
"Make a `group-element' object containg `object' as element."
(make-instance 'group-element :element object))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Interface
(defun add-group (name elements)
"Define a group called `name' (a string) containing the elements `elements',
which must be a list of pathnames and/or buffers, and add it to
the list of defined groups."
(setf (gethash name (groups *application-frame*))
(make-instance
'standard-group
:name name
:elements (mapcar #'make-group-element elements))))
(defun get-group (name)
"Return the group with the name `name'."
(or (gethash name (groups *application-frame*))
(gethash name *persistent-groups*)))
(defun get-active-group ()
"Return the currently active group."
(or (active-group *application-frame*)
(deselect-group)))
(defun deselect-group ()
"Deselect the currently active group."
(setf (active-group *application-frame*)
(make-instance 'current-buffer-group
:name "none")))
(defmacro with-group-buffers ((buffers group &key keep) &body body)
"Make sure that all files designated by `group' are open in
buffers during the evaluation of `body'. If `keep' is NIL, all
buffers created by this macro will be saved and killed after
`body' has run. Also, `buffers' will be bound to a list of the
buffers containing the files designated by `group' while `body'
is run."
(let ((buffers-before-sym (gensym))
(buffers-after-sym (gensym))
(buffer-diff-sym (gensym))
(group-val-sym (gensym)))
`(let ((,buffers-before-sym (buffers *application-frame*))
(,group-val-sym ,group))
(ensure-group-buffers ,group-val-sym)
(let* ((,buffers-after-sym (buffers *application-frame*))
(,buffer-diff-sym (set-difference ,buffers-after-sym
,buffers-before-sym))
(,buffers (group-buffers ,group-val-sym)))
(unwind-protect (progn , at body)
(unless ,keep
(loop for buffer in ,buffer-diff-sym
do (save-buffer buffer *application-frame*)
do (kill-buffer buffer))))))))
(defmacro define-group (name (group-arg &rest args) &body body)
"Define a persistent group named `name'. `Body' should return a
list of pathnames and will be used to calculate which files are
designated by the group. `Args' should be two-element lists, with
the first element bound to the result of evaluating the second
element. The second element will be evaluated when the group is
selected to be the active group by the user."
(let ((name-val-sym (gensym))
(group-val-sym (gensym)))
`(let ((,name-val-sym ,name))
(assert (stringp ,name-val-sym))
(setf (gethash ,name-val-sym *persistent-groups*)
(make-instance 'custom-group
:name ,name-val-sym
:pathname-lister #'(lambda (,group-val-sym)
(destructuring-bind
(&key ,@(mapcar #'(lambda (arg)
`((,arg ,arg)))
(mapcar #'first args)))
(value-plist ,group-val-sym)
(let ((,group-arg ,group-val-sym))
, at body)))
:select-response #'(lambda (group)
(declare (ignorable group))
,@(loop for (name form) in args
collect `(setf (getf (value-plist group) ',name) ,form))))))))
(define-group "Current Directory Files" (group)
(declare (ignore group))
(directory (make-pathname :directory (pathname-directory (filepath (current-buffer)))
:name :wild
:type :wild)))
(define-group "Directory Files" (group (directory (accept 'pathname
:prompt "Directory"
:default (directory-of-buffer (current-buffer))
:insert-default t)))
(declare (ignore group))
(directory (make-pathname :directory (pathname-directory directory)
:name :wild
:type :wild)))
(define-group "Directory Lisp Files" (group (directory (accept 'pathname
:prompt "Directory"
:default (directory-of-buffer (current-buffer))
:insert-default t)))
(declare (ignore group))
(directory (make-pathname :directory (pathname-directory directory)
:name :wild
:type "lisp")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; CLIM interface stuff.
(define-presentation-method accept
((type group) stream view &key (default nil defaultp)
(default-type type))
(multiple-value-bind (object success string)
(complete-input stream
(lambda (so-far action)
(complete-from-possibilities
so-far
(append (loop for key being the hash-keys of (groups *application-frame*)
collecting key)
(loop for key being the hash-keys of *persistent-groups*
collecting key))
'(#\Space)
:action action
:name-key #'identity
:value-key #'identity))
:partial-completers '(#\Space)
:allow-any-input nil)
(cond (success
(values (get-group object) type))
((and (zerop (length string)) defaultp)
(values default default-type))
(t (values string 'string)))))
(define-presentation-method present (object (type group) stream view &key)
(let ((name (name object)))
(princ name stream)))
(define-presentation-method present ((object synonym-group) (type group) stream view &key)
(if (get-group (other-name object))
(present (get-group (other-name object)) type :stream stream :view view)
(error 'group-not-found :group-name (other-name object))))
More information about the Climacs-cvs
mailing list