Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv9361
Modified Files:
climacs.asd
Added Files:
structured-editing.lisp
Log Message:
Added Structedit Mode to Climacs.
--- /project/climacs/cvsroot/climacs/climacs.asd 2008/01/07 23:08:14 1.65
+++ /project/climacs/cvsroot/climacs/climacs.asd 2008/01/09 09:47:16 1.66
@@ -41,6 +41,7 @@
;; (:file "ttcn3-syntax" :depends-on ("packages"))
(:file "climacs-lisp-syntax" :depends-on ("core" "groups"))
(:file "climacs-lisp-syntax-commands" :depends-on ("climacs-lisp-syntax" "misc-commands"))
+ (:file "structured-editing" :depends-on ("climacs-lisp-syntax-commands"))
(:file "c-syntax" :depends-on ("core"))
(:file "c-syntax-commands" :depends-on ("c-syntax" "misc-commands"))
#+nil(:file "java-syntax" :depends-on ("core"))
--- /project/climacs/cvsroot/climacs/structured-editing.lisp 2008/01/09 09:47:16 NONE
+++ /project/climacs/cvsroot/climacs/structured-editing.lisp 2008/01/09 09:47:16 1.1
;;; -*- Mode: Lisp; Package: CLIMACS-STRUCTEDIT -*-
;;; (c) copyright 2008 by
;;; Troels Henriksen (athas(a)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 structural editing commands for the Lisp syntax
;;; in Climacs. These commands were inspired by Paredit, which was
;;; originally written by Taylor "Riastradh" Campbell for GNU
;;; Emacs. In particular, many docstrings have been copied verbatim,
;;; then modified.
;;; This is a work in progress, be aware that problems are likely to
;;; arise, and that the editing commands are not yet completely
;;; comprehensive. Patches are, of course, welcome.
;;; You must do M-x Structedit Mode to enable these commands.
(defpackage :climacs-structedit
(:use :clim-lisp :clim :esa :esa-utils :drei :drei-buffer :drei-base :drei-core
:drei-motion :drei-editing :drei-syntax :drei-lr-syntax :drei-lisp-syntax)
(:shadow clim:form))
(in-package :climacs-structedit)
(define-syntax-mode structedit-mode ()
()
(:documentation "A mode for Paredit-style editing in Lisp syntax.")
(:applicable-syntaxes lisp-syntax))
(define-mode-toggle-commands com-structedit-mode (structedit-mode "Structedit")
:command-table lisp-table)
(make-command-table 'structedit-table
:errorp nil)
(defmethod syntax-command-tables append ((syntax structedit-mode))
'(structedit-table))
(defun delete-form (buffer form)
"Delete `form' from `buffer'."
(delete-buffer-range
buffer (start-offset form) (size form)))
(define-command (com-open-list :name t :command-table structedit-table)
((n 'integer :default 0))
"Insert a balanced parenthesis pair.
With an argument N, put the closing parentheses after N
S-expressions forward. If in string or comment, insert a single
opening parenthesis. If in a character literal, replace the
character literal with #\(."
(cond ((in-string-p (current-syntax) (point))
(insert-character #\())
((in-comment-p (current-syntax) (point))
(insert-character #\())
((in-character-p (current-syntax) (point))
(delete-form (current-buffer) (form-around (current-syntax) (offset (point))))
(insert-sequence (point) "#\\("))
(t
(when (and (not (zerop n))
(forward-expression (point) (current-syntax) 1 nil))
(backward-expression (point) (current-syntax) 1 nil))
(insert-character #\()
(forward-expression (point) (current-syntax) n nil)
(insert-character #\))
(backward-object (point))
(backward-expression (point) (current-syntax) n nil))))
(define-command (com-wrap-expression :name t :command-table structedit-table)
((n 'integer :default 1))
"Wrap the following N S-expressions in a list.
Automatically indent the newly wrapped S-expressions. As a
special case, if the point is at the end of a list, simply insert
a pair of parentheses, rather than insert a lone opening
parenthesis and then signal an error, in the interest of
preserving structural validity."
(com-open-list n))
(define-command (com-close-list-and-newline :name t :command-table structedit-table)
()
"Move past one closing delimiter, add a newline, and reindent."
(cond ((or (in-string-p (current-syntax) (point))
(in-comment-p (current-syntax) (point)))
(insert-character #\)))
((in-character-p (current-syntax) (point))
(delete-form (current-buffer) (form-around (current-syntax) (offset (point))))
(insert-sequence (point) "#\\)"))
((forward-up (point) (current-syntax) 1 nil)
(insert-object (point) #\Newline)
(indent-current-line (current-view) (point)))))
(defun delete-object-structurally (delete-fn move-fn immediate-form-fn
border-offset-fn
at-border-fn)
"Delete an object at `(point)' structurally. `Delete-fn' is
either `forward-delete-object' or `backward-delete-object',
`move-fn' is either `forward-object' or `backward-object',
`immediate-form-fn' is some form selector, `border-offset-fn' is
either `end-offset' or `begin-offset', `at-border-fn' is a
function used to determine whether or not `(point)' is at the end
of a structural object."
(let ((immediate-form (funcall immediate-form-fn (current-syntax) (offset (point))))
(form-around (form-around (current-syntax) (offset (point)))))
(cond ((and (or (form-string-p immediate-form)
(form-list-p immediate-form))
(= (funcall border-offset-fn immediate-form)
(offset (point))))
(funcall move-fn (point)))
((funcall at-border-fn (current-syntax) (point))
(when (null (form-children (list-at-mark (current-syntax) (point))))
(delete-form (current-buffer) form-around)))
((and (form-character-p immediate-form)
(= (funcall border-offset-fn immediate-form)
(offset (point))))
(delete-form (current-buffer) immediate-form))
(t (funcall delete-fn (point))))))
(define-command (com-forward-delete-object-structurally
:name t :command-table structedit-table)
((force 'boolean :default nil))
"Delete a character forward or move forward over a delimiter.
If on an opening S-expression delimiter, move forward into the
S-expression. If on a closing S-expression delimiter, refuse to
delete unless the S-expression is empty, in which case delete the
whole S-expression. If `force' is true, simply delete a character
forward, without regard for delimiter balancing."
(if force
(forward-delete-object (point))
(delete-object-structurally #'forward-delete-object #'forward-object
#'form-after #'start-offset
#'location-at-end-of-form)))
(define-command (com-backward-delete-object-structurally
:name t :command-table structedit-table)
((force 'boolean :default nil))
"Delete a character backward or move backward over a delimiter.
If on an ending S-expression delimiter, move backward into the
S-expression. If on an opening S-expression delimiter, refuse to
delete unless the S-expression is empty, in which case delete the
whole S-expression. If `force' is true, simply delete a
character backward, without regard for delimiter balancing."
(if force
(backward-delete-object (point))
(delete-object-structurally #'backward-delete-object #'backward-object
#'form-before #'end-offset
#'location-at-beginning-of-form)))
(define-command (com-insert-double-quote-structurally
:name t :command-table structedit-table)
((n 'integer :default 0))
"Insert a pair of double-quotes.
With a prefix argument N, wrap the following N S-expressions in
double-quotes, escaping intermediate characters if necessary.
Inside a comment, insert a literal double-quote.
At the end of a string, move past the closing double-quote.
In the middle of a string, insert a backslash-escaped double-quote.
If in a character literal, replace the character literal with #\\\"."
(cond ((in-comment-p (current-syntax) (point))
(insert-character #\"))
((at-end-of-string-p (current-syntax) (point))
(forward-object (point)))
((in-string-p (current-syntax) (point))
(insert-sequence (point) "\\\""))
((in-character-p (current-syntax) (point))
(delete-form (current-buffer) (form-around (current-syntax) (offset (point))))
(insert-sequence (point) "#\\\""))
(t
(let ((old-offset (offset (point))))
(forward-expression (point) (current-syntax) n nil)
(insert-buffer-object (current-buffer) old-offset #\")
(insert-character #\")
(backward-object (point))
(backward-expression (point) (current-syntax) (min 1 n) nil)))))
(define-command (com-wrap-expression-in-doublequote :name t :command-table structedit-table)
((n 'integer :default 1))
"Move to the end of the string, insert a newline, and indent.
If not in a string, act as `Insert Double Quote Structurally'; if
no prefix argument is specified, the default is to wrap one
S-expression, however, not zero."
(if (in-string-p (current-syntax) (point))
(setf (offset (point))
(1+ (end-offset (form-around (current-syntax) (point)))))
(com-insert-double-quote-structurally n)))
(define-command (com-splice-list :name t :command-table structedit-table)
((kill-backward 'boolean :default nil))
"Splice the list that the point is on by removing its delimiters.
With a prefix argument as in `C-u', kill all S-expressions
backward in the current list before splicing all S-expressions
forward into the enclosing list."
(let ((list (list-at-mark (current-syntax) (point))))
(when list
(let ((begin-mark (make-buffer-mark (current-buffer) (start-offset list)))
(end-mark (make-buffer-mark (current-buffer) (end-offset list))))
(when kill-backward
(loop until (eq (list-at-mark (current-syntax) (offset (point)))
(or (form-before (current-syntax) (offset (point)))
(form-around (current-syntax) (offset (point)))))
do (backward-delete-expression (point) (current-syntax) 1 nil)))
(delete-buffer-range (current-buffer) (offset begin-mark) 1)
(delete-buffer-range (current-buffer) (1- (offset end-mark)) 1)))))
(define-command (com-kill-line-structurally :name t :command-table structedit-table)
()
"Kill a line as if with \"Kill Line\", but respecting delimiters.
In a string, act exactly as \"Kill Line\" but do not kill past
the closing string delimiter. On a line with no S-expressions on
it starting after the point or within a comment, act exactly as
\"Kill Line\". Otherwise, kill all S-expressions that start
after the point."
(let ((form-around (form-around (current-syntax) (offset (point))))
(form-after (form-after (current-syntax) (offset (point))))
(comment (comment-at-mark (current-syntax) (point))))
(cond ((empty-line-p (point))
(forward-delete-object (point)))
((in-string-p (current-syntax) (point))
(if (= (buffer-line-number (current-buffer) (end-offset form-around))
(line-number (point)))
;; Delete from point until the end of the string, but
;; keep the ending delimiter.
(kill-region (point) (1- (end-offset form-around)))
;; Delete from point until end of line.
(kill-region (point) (end-of-line (clone-mark (point))))))
((in-line-comment-p (current-syntax) (point))
;; Delete until end of line
(kill-region (point) (end-of-line (clone-mark (point)))))
((in-long-comment-p (current-syntax) (point))
(if (= (buffer-line-number (current-buffer) (end-offset comment))
(line-number (point)))
;; End of comment on same line as point, if a complete
;; long comment, don't delete the ending delimiter
(kill-region (point) (- (end-offset comment)
(if (form-complete-p comment)
2 0)))
;; Delete from point until end of line.
(kill-region (point) (end-of-line (clone-mark (point))))))
((= (buffer-line-number (current-buffer) (start-offset form-after))
(line-number (point)))
(forward-kill-expression (point) (current-syntax))
(loop for form-after = (form-after (current-syntax) (offset (point)))
while (and form-after
(= (buffer-line-number (current-buffer) (start-offset form-after))
(line-number (point))))
do (forward-kill-expression (point) (current-syntax) 1 t))))))
(set-key `(com-open-list ,*numeric-argument-marker* ,*numeric-argument-marker*)
'structedit-table
'(#\())
(set-key `(com-wrap-expression ,*numeric-argument-marker*)
'structedit-table
'((#\( :meta :shift)))
(set-key 'com-close-list-and-newline
'structedit-table
'(#\)))
(set-key `(com-forward-delete-object-structurally ,*numeric-argument-marker*)
'structedit-table
'((#\d :control)))
(set-key `(com-backward-delete-object-structurally ,*numeric-argument-marker*)
'structedit-table
'((#\Backspace)))
(set-key `(com-insert-double-quote-structurally ,*numeric-argument-marker*)
'structedit-table
'((#\")))
(set-key `(com-wrap-expression-in-doublequote ,*numeric-argument-marker*)
'structedit-table
'((#\" :meta :shift)))
(set-key `(com-splice-list ,*numeric-argument-marker*)
'structedit-table
'((#\s :meta)))
(set-key 'com-kill-line-structurally
'structedit-table
'((#\k :control)))
