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))
......
This diff is collapsed.
......@@ -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
......
......@@ -756,6 +756,10 @@ FIXME: no it doesn't."
"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 @@ Text in the rectangle will be shifted right."
#'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
......@@ -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
......
......@@ -317,15 +317,19 @@ using the case of those objects if USE-REGION-CASE is true."
(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 @@ using the case of those objects if USE-REGION-CASE is true."
(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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment