Commit a53496d3 authored by Troels Henriksen's avatar Troels Henriksen

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.
parent 53b02461
......@@ -46,8 +46,9 @@ Copyright @copyright{} 2004 Robert Strandh.
@chapter Introduction
You are reading the Climacs internals manual. This document contains
a detailed description of various Climacs protocols.
You are reading the Climacs internals manual. This document contains a
detailed description of various Climacs protocols and other internal
details.
@chapter Buffer protocol
......@@ -2100,7 +2101,188 @@ A slot accessor provided by the Climacs implemention of the kill ring class, whi
flexicursor assocated with kill-ring.
@end deffn
@chapter Group facilities
@section Overview
The Climacs group functionality is implemented through a simple protocol
that permits the definition of new kinds of groups, as well as a number
of utility functions and macros based on the protocol. Specific groups
are stored in an @code{equalp} hash table in the Climacs frame object
with groups keyed by their name as a string (the choice of @code{equalp}
as the hash table test means that group names are not
case-sensitive). Persistent groups are stored in a global @code{equalp}
hash table, also keyed by the name of the group as a string.
@footnote{The use of a global hash table means that two Climacs sessions
running in the same image might clobber each others group settings -
this is bad and indicative of a larger problem regarding running
multiple Climacs sessions.} The active group is also stored in the
Climacs frame object, typically as a ``synonym'' group, that forwards
protocol methods to a group with a specified name. This is done so that
it is possible to redefine a specific group while it is selected, and
have the changes reflected in the selected group. Since redefinition of
a group merely means creating and inserting a new object for the key in
the hash table, the slot in the Climacs frame object would continue to
refer to the old definition of the group, if this added indirection was
not done.
The group protocol and its implementation is still very basic, and may
fail when faced with situations such as file access rights changing and
killing of buffers at unpredicted times.
@section Basic group protocol
@deftp {Protocol Class} group
The base class for all group objects. This class is not meant to be
instantiated.
@end deftp
@deftp {Initarg} :name
The name of the group. The @var{:name} initarg is mandatory, because
every group must have a name.
@end deftp
@deftp {Class} group-element
Objects of this class designate a single element, either a buffer or a
file. A subclass of @code{group}.
@end deftp
@deftp {Initarg} :element
This initarg provides the element that the @code{group-element} instance
should designate.
@end deftp
@deftp {Class} standard-group
Objects of this class designate a sequence of elements, normally
instances of @code{group-element}.
@end deftp
@deftp {Initarg} :elements
This initarg provides the elements that the @code{standard-group}
instance should designate.
@end deftp
@deftp {Class} current-buffer-group
Objects of this class designate the ``current buffer''. That is,
whenever instances of this class are queried for a list of buffers (for
example, via @code{group-buffers}), they will respond with a list of one
element, the currently active buffer.
@end deftp
@deffn {Generic Function} {group-buffers} group
Get a list of buffers in @var{group}. Only already existing buffers will
be returned, use @code{ensure-group-buffers} if you want all buffers
defined by the group.
@end deffn
@deffn {Generic Function} {ensure-group-buffers} group
For each pathname in @var{group} that does not have a corresponding
buffer, open a buffer for that pathname.
@end deffn
@deffn {Generic Function} {select-group} group
Tell the group object @var{group} that the user has selected it. This
method is responsible for setting the active group. If @var{group} needs
additional information, it should query the user when this method is
invoked. The standard method should be sufficient for most group
classes.
@end deffn
@deffn {Generic Function} {display-group-contents} group
Display the contents of @var{group} to @var{stream}. Basically, this
should describe which buffers or files would be affected by group-aware
commands if @var{group} was the active group. There is no standard
format for the output, but it is intended for displaying to the user. It
is acceptable to only define methods where @var{stream} is a CLIM
@code{extended-output-stream}.
@end deffn
@section Group management
A number of functions are provided to manage definition and management
of groups. It is not possible to remove groups (excluding using
@code{remhash} explicitly), but there are functions to add and get groups
based on their name.
@deffn {Function} {add-group} name elements
Define a group called @var{name} (a string) containing the elements
@var{elements}, which must be a list of pathnames and/or buffers, and
add it to the list of defined groups.
@end deffn
@deffn {Function} {get-group} name
Return the group with the name @var{name}.
@end deffn
@deffn {Function} {get-active-group}
Return the currently active group.
@end deffn
@deffn {Function} {deselect-group}
Deselect the currently active group.
@end deffn
@section Expanded group facilities
On top of the basic protocol, a number of additional and useful classes,
functions and macros have been defined.
@deffn {Macro} {with-group-buffers} (buffers group &key keep) &body body
Make sure that all files designated by @var{group} are open in buffers
during the evaluation of @var{body}. If @var{keep} is NIL, all buffers
created by this macro will be saved and killed after @var{body} has
run. Also, @var{buffers} will be bound to a list of the buffers
containing the files designated by @var{group} while @var{body} is run.
@end deffn
@deffn {Macro} {define-group} (name (group-arg &rest args) &body body)
Define a persistent group named @var{name}. @var{Body} should return a
list of pathnames and will be used to calculate which files are
designated by the group. @var{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.
@node Index
@deftp {Error Condition} group-not-found
This condition is signaled whenever a synonym group is unable to find
the group that it is supposed to forward method invocations to.
@end deftp
@deftp {Method} {group-name} (condition @code{group-not-found})
When invoked, this method returns the name of the group that could not
be found.
@end deftp
@deftp {Class} synonym-group
Objects of this class forwards all calls of group protocol methods to a
group with a specified name. If a group of the requested name cannot be
found, a condition of type @code{group-not-found} will be signalled.
@end deftp
@deftp {Initarg} :other-name
The name of the buffer an instance of @code{synonym-group} should
forward method calls to.
@end deftp
@deftp {Class} custom-group
Instances of this class will call a provided function when it is
selected or asked for pathnames.
@end deftp
@deftp {Initarg} :pathname-lister
The function that will be called for the @code{custom-group} object to
retrieve the pathnames that the group designates. This should be a
function of one required argument, the group object, and it should
return a list of pathname objects.
@end deftp
@deftp {Initarg} :select-response
The function that will be called when the @code{custom-group} object is
selected as the active group. This should be a function of a single
required argument, the group object, and it is called for side effects.
@end deftp
@unnumbered Index
@printindex cp
......
......@@ -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"))
......
......@@ -596,6 +596,33 @@ spaces only."))
(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 @@ spaces only."))
(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))
......
;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-
;;; (c) copyright 2006 by
;;; Troels Henriksen (athas@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 ,@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))
,@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)))