[nongnu] elpa/paredit fd2c399 049/224: Implement `paredit-kill-ring-save' and `paredit-kill-region'.

[ELPA Syncer]

branch: elpa/paredit
commit fd2c3993409a743c14df827dea64923b38a5d2c8
Author: Taylor R Campbell <campbell@mumble.net>
Commit: Taylor R Campbell <campbell@mumble.net>

    Implement `paredit-kill-ring-save' and `paredit-kill-region'.
    
    Ignore-this: 9e77f0436cdce47e15d1dba998902b77
    
    These are an unfinished experiment.  When the experiment is finished,
    if it is successful, then, in Paredit Mode, `C-w' will be bound to
    `paredit-kill-region', `M-w' perhaps to `paredit-kill-ring-save', and
    `C-y' to `paredit-yank' (not yet implemented).
    
    darcs-hash:20100918231829-00fcc-c0a34e7f81243fa6c1ee535cb86c692a0f589ed3
---
 paredit.el | 106 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 106 insertions(+)

diff --git a/paredit.el b/paredit.el
index be9c6fb..4a3a31e 100644
--- a/paredit.el
+++ b/paredit.el
@@ -1593,6 +1593,112 @@ With a numeric prefix argument N, do `kill-line' that 
many times."
                                    (t
                                     (point))))))))
 
+;;;; Safe Region Killing/Copying
+
+;;; This is an experiment.  It's not enough: `paredit-kill-ring-save'
+;;; is always safe; it's `yank' that's not safe, but even trickier to
+;;; implement than `paredit-kill-region'.  Also, the heuristics for
+;;; `paredit-kill-region' are slightly too conservative -- they will
+;;; sometimes reject killing regions that would be safe to kill.
+;;; (Consider, e,g., a region that starts in a comment and ends in the
+;;; middle of a symbol at the end of a line: that's safe to kill, but
+;;; `paredit-kill-region' won't allow it.)  I don't know whether they
+;;; are too liberal: I haven't constructed a region that is unsafe to
+;;; kill but which `paredit-kill-region' will kill, but I haven't ruled
+;;; out the possibility either.
+
+(defun paredit-kill-ring-save (beginning end)
+  "Save the balanced region, but don't kill it, like `kill-ring-save'.
+If the text of the region is imbalanced, signal an error instead.
+With a prefix argument, disregard any imbalance."
+  (interactive "r")
+  (if (not current-prefix-arg)
+      ;; Check that the region is balanced.
+      (save-restriction
+        (narrow-to-region beginning end)
+        (if (fboundp 'check-parens)
+            (check-parens)
+            (save-excursion
+              (goto-char (point-min))
+              (while (not (eobp))
+                (forward-sexp))))))
+  (setq this-command 'kill-ring-save)
+  (kill-ring-save beginning end))
+
+(defun paredit-kill-region (beginning end &optional yank-handler)
+  "Kill balanced text between point and mark, like `kill-region'.
+If that text is imbalanced, signal an error instead."
+  (interactive "r")
+  (if (and beginning end)
+      ;; Check that region begins and ends in a sufficiently similar
+      ;; state, so that deleting it will leave the buffer balanced.
+      (save-excursion
+        (goto-char beginning)
+        (let* ((state (paredit-current-parse-state))
+               (state* (parse-partial-sexp beginning end nil nil state)))
+          (paredit-check-region-state state state*))))
+  (setq this-command 'kill-region)
+  (kill-region beginning end yank-handler))
+
+(defun paredit-check-region-state (beginning-state end-state)
+  (paredit-check-region-state-depth beginning-state end-state)
+  (paredit-check-region-state-string beginning-state end-state)
+  (paredit-check-region-state-comment beginning-state end-state)
+  (paredit-check-region-state-char-quote beginning-state end-state))
+
+(defun paredit-check-region-state-depth (beginning-state end-state)
+  (let ((beginning-depth (nth 0 beginning-state))
+        (end-depth (nth 0 end-state)))
+    (if (not (= beginning-depth end-depth))
+        (error "Mismatched parenthesis depth: %S at start, %S at end."
+               beginning-depth
+               end-depth))))
+
+(defun paredit-check-region-state-string (beginning-state end-state)
+  (let ((beginning-string-p (nth 3 beginning-state))
+        (end-string-p (nth 3 end-state)))
+    (if (not (eq beginning-string-p end-string-p))
+        (error "Mismatched string state: start %sin string, end %sin string."
+               (if beginning-string-p "" "not ")
+               (if end-string-p "" "not ")))))
+
+(defun paredit-check-region-state-comment (beginning-state end-state)
+  (let ((beginning-comment-state (nth 4 beginning-state))
+        (end-comment-state (nth 4 end-state)))
+    (if (not (or (eq beginning-comment-state end-comment-state)
+                 (and (eq beginning-comment-state nil)
+                      (eq end-comment-state t)
+                      (eolp))))
+        (error "Mismatched comment state: %s"
+               (cond ((and (integerp beginning-comment-state)
+                           (integerp end-comment-state))
+                      (format "depth %S at start, depth %S at end."
+                              beginning-comment-state))
+                     ((integerp beginning-comment-state)
+                      "start in nested comment, end otherwise.")
+                     ((integerp end-comment-state)
+                      "end in nested comment, start otherwise.")
+                     (beginning-comment-state
+                      "start in comment, end not in comment.")
+                     (end-comment-state
+                      "end in comment, start not in comment.")
+                     (t
+                      (format "start %S, end %S."
+                              beginning-comment-state
+                              end-comment-state)))))))
+
+(defun paredit-check-region-state-char-quote (beginning-state end-state)
+  (let ((beginning-char-quote (nth 5 beginning-state))
+        (end-char-quote (nth 5 end-state)))
+    (if (not (eq beginning-char-quote end-char-quote))
+        (let ((phrase "character quotation"))
+          (error "Mismatched %s: start %sin %s, end %sin %s."
+                 phrase
+                 (if beginning-char-quote "" "not ")
+                 phrase
+                 (if end-char-quote "" "not ")
+                 phrase)))))
+
 ;;;; Cursor and Screen Movement
 
 (eval-and-compile