From: Taylor R. Campbell Date: Fri, 16 Jun 2006 19:02:27 +0000 (+0000) Subject: New Edwin library Paredit. X-Git-Tag: 20090517-FFI~1005 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9403bfacd1ea743d3bafb992cbf203563459a00c;p=mit-scheme.git New Edwin library Paredit. --- diff --git a/v7/src/edwin/decls.scm b/v7/src/edwin/decls.scm index 78c52b81c..a25f82936 100644 --- a/v7/src/edwin/decls.scm +++ b/v7/src/edwin/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: decls.scm,v 1.75 2006/06/16 18:35:45 riastradh Exp $ +$Id: decls.scm,v 1.76 2006/06/16 19:02:27 riastradh Exp $ Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology Copyright 1995,1996,1997,1998,1999,2000 Massachusetts Institute of Technology @@ -181,6 +181,7 @@ USA. "occur" "os2" "os2com" + "paredit" "pasmod" "print" "process" diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index ec660322f..16e515984 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.295 2006/06/16 17:55:27 riastradh Exp $ +$Id: edwin.pkg,v 1.296 2006/06/16 19:02:27 riastradh Exp $ Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology Copyright 1995,1996,1997,1998,1999,2000 Massachusetts Institute of Technology @@ -1732,6 +1732,29 @@ USA. ynode-type ynode-value-node) (initialization (initialize-package!))) + +(define-package (edwin paredit) + (files "paredit") + (parent (edwin)) + (export (edwin) + edwin-command$paredit-backslash + edwin-command$paredit-backward + edwin-command$paredit-backward-delete + edwin-command$paredit-close-list + edwin-command$paredit-close-list-and-newline + edwin-command$paredit-close-string-and-newline + edwin-command$paredit-doublequote + edwin-command$paredit-forward + edwin-command$paredit-forward-delete + edwin-command$paredit-kill + edwin-command$paredit-mode + edwin-command$paredit-newline + edwin-command$paredit-open-list + edwin-command$paredit-raise-sexp + edwin-command$paredit-recentre-on-sexp + edwin-command$paredit-splice-sexp + edwin-command$paredit-wrap-sexp + edwin-mode$paredit)) (define-package (edwin news-reader) (files "snr") diff --git a/v7/src/edwin/loadef.scm b/v7/src/edwin/loadef.scm index 520c5b9e1..3052685f4 100644 --- a/v7/src/edwin/loadef.scm +++ b/v7/src/edwin/loadef.scm @@ -1,8 +1,10 @@ #| -*-Scheme-*- -$Id: loadef.scm,v 1.48 2003/02/14 18:28:12 cph Exp $ +$Id: loadef.scm,v 1.49 2006/06/16 19:02:27 riastradh Exp $ -Copyright 1986, 1989-2001 Massachusetts Institute of Technology +Copyright 1986,1989,1990,1991,1992,1993 Massachusetts Institute of Technology +Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology +Copyright 2000,2001,2006 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -226,6 +228,15 @@ variable's value is #F, the text is printed using LPR-COMMAND." (define-autoload-command 'step-defun 'STEPPER "Single-step the definition that the point is in or before.") +(define-library 'PAREDIT + '("paredit" (EDWIN PAREDIT))) + +(define-autoload-minor-mode 'paredit "Paredit" 'PAREDIT + "Minor mode for pseudo-structurally editing Lisp code.") + +(define-autoload-command 'paredit-mode 'PAREDIT + "Toggle pseudo-structural editing of Lisp code.") + ;;; **************** (define-library 'NEWS-READER diff --git a/v7/src/edwin/paredit.scm b/v7/src/edwin/paredit.scm new file mode 100644 index 000000000..a0acf055e --- /dev/null +++ b/v7/src/edwin/paredit.scm @@ -0,0 +1,790 @@ +#| -*-Scheme-*- + +$Id: paredit.scm,v 1.1 2006/06/16 19:02:27 riastradh Exp $ + +This code is written by Taylor R. Campbell and placed in the Public +Domain. All warranties are disclaimed. + +|# + +;;;; Paredit: Parenthesis-Editing Minor Mode (based on paredit.el) + +(declare (usual-integrations)) + +(define-command paredit-mode + "Toggle pseudo-structural editing of Lisp code. +With a prefix argument, enable paredit mode if the argument is + positive, and disable paredit mode if not." + "P" + (lambda (argument) + (let ((mode (ref-mode-object paredit))) + (if (if argument + (positive? (command-argument-value argument)) + (not (current-minor-mode? mode))) + (enable-current-minor-mode! mode) + (disable-current-minor-mode! mode))))) + +(define-minor-mode paredit "Paredit" + "Minor mode for pseudo-structurally editing Lisp code. + +\\{paredit}") + +(for-each (lambda (key) + (define-key 'paredit (car key) (cadr key))) + '( + ;; Insertion commands + (#\( paredit-open-list) + (#\) paredit-close-list-and-newline) + (#\M-\) paredit-close-list) + (#\M-\" paredit-close-string-and-newline) + (#\" paredit-doublequote) + (#\\ paredit-backslash) + (#\return paredit-newline) ; This defies the convention, + (#\C-j newline) ; but I prefer it, and you can + ; customize it yourself anyway. + ;; Killing & deleting + (#\C-d paredit-forward-delete) + (#\rubout paredit-backward-delete) + (#\C-k paredit-kill) + + ;; Movement & navigation + (#\C-M-f paredit-forward) + (#\C-M-b paredit-backward) +;;; (#\C-M-u backward-up-list) ; These two are built-in. +;;; (#\C-M-d down-list) + (#\C-M-p backward-down-list) + (#\C-M-n up-list) + ((#\C-c #\C-M-l) paredit-recentre-on-sexp) + + ;; Depth-changing commands + (#\M-\( paredit-wrap-sexp) + (#\M-r paredit-raise-sexp) + (#\M-s paredit-splice-sexp) ;++ This conflicts with M-s + ;++ for STEP-DEFUN. Hmmmm. + )) + +;;;; Basic Editing Commands + +(define-command paredit-open-list + "Insert a balanced round bracket parenthesis pair. +With a prefix argument N, put the closing round bracket after N + S-expressions forward. +If in string or comment, inserts a single opening round bracket. +If in a character literal, does nothing. This prevents accidentally + changing what was in the character literal to a meaningful delimiter + unintentionally." + "P" + (let ((open-list + (lambda (argument) + (insert-sexp-pair #\( #\) + (or (command-argument-value argument) + 0))))) + (lambda (argument) + (if (group-start? (current-point)) + (open-list #f) + (let ((state (current-parse-state))) + (cond ((or (parse-state-in-string? state) + (parse-state-in-comment? state)) + (insert-char #\( )) + ((not (mark-right-char-quoted? (current-point))) + (open-list argument)))))))) + +(define-command paredit-close-list + "Move past the closing delimiter of the list the point is on. +Delete all extraneous space before the closing delimiter, but do not + move it past comments between it and the point. +If in a string or comment, insert a single closing round bracket. +If in a character literal, do nothing. This prevents accidentally + changing what was in the character literal to a meaningful delimiter + unintentionally." + () + (lambda () + (let ((point (current-point))) + (if (group-start? point) + (editor-failure "No list to close at buffer start.") + (let ((state (current-parse-state))) + (cond ((or (parse-state-in-string? state) + (parse-state-in-comment? state)) + (insert-char #\) )) + ((not (mark-right-char-quoted? point)) + (paredit-move-past-close-and-reindent point state) + (flash-sexp-match)))))))) + +(define-command paredit-close-list-and-newline + "Move past close of the current list, insert a newline, & indent. +If in a string or comment, insert a single closing round bracket. +If in a character literal, do nothing. This prevents accidentally + changing what was in the character literal to a meaningful delimiter + unintentionally." + () + (lambda () + (let ((point (current-point))) + (if (group-start? point) + (editor-failure "No list to close at buffer start.") + (let ((state (current-parse-state))) + (cond ((or (parse-state-in-string? state) + (parse-state-in-comment? state)) + (insert-char #\) )) + (else + (paredit-move-past-close-and-reindent + (if (mark-right-char-quoted? point) + (mark1+ point) + point) + state) + (insert-newline-preserving-comment) + (lisp-indent-line-and-sexp) + (flash-sexp-match #t)))))))) + +(define (paredit-move-past-close-and-reindent mark state) + (cond ((forward-up-one-list mark) + => (lambda (after-close) + (undo-record-point!) + (set-current-point! after-close) + (let loop ((before-close (mark-1+ after-close))) + (if (mark= (horizontal-space-end + (line-start before-close 0)) + before-close) + ;; The closing delimiter is the first thing on the + ;; line. If the previous line ends in a comment, + ;; we stop here; otherwise, we go on. + (let ((end-of-prev (line-end before-close -1)) + (location (parse-state-location state))) + (cond ((and (not (mark<= end-of-prev location)) + (parse-state-in-comment? + (parse-partial-sexp location + end-of-prev + #f #f + state))) + ;; Nothing more to be done, so just + ;; indent the line we're on (which has + ;; the closing delimiter). + (lisp-indent-line #f)) + (else + ;; More to delete. + (delete-string end-of-prev before-close) + (loop end-of-prev)))) + ;; We've reached our goal, though there might be + ;; some indentation between the closing delimiter + ;; and where we want it to be. We must take care, + ;; though, to preserve whitespace characters. + (let* ((mark + (horizontal-space-start before-close)) + (escaped + (and (mark-right-char-quoted? mark) + (mark-right-char mark)))) + (delete-horizontal-space before-close) + (if escaped + (insert-char escaped mark))))))) + (else + (editor-error "No closing delimiter to move over.")))) + +(define-command paredit-close-string-and-newline + "Move to the end of the string, insert a newline, and indent. +If not in a string, act as `paredit-doublequote'." + () + (lambda () + (let ((state (current-parse-state))) + (if (not (parse-state-in-string? state)) + ((ref-command paredit-doublequote)) + (let ((after-string (parse-state-end-of-sexp state))) + (set-current-point! after-string) + (insert-newline) + (lisp-indent-line-and-sexp) + (flash-sexp-match #f after-string)))))) + +(define-command paredit-doublequote + "Insert a pair of double-quotes. +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, do nothing. This prevents accidentally + changing what was in the character literal to a meaningful delimiter + unintentionally." + () + (lambda () + (let ((state (current-parse-state))) + (cond ((parse-state-in-string? state) + (if (mark= (mark-1+ (parse-state-end-of-sexp state)) + (current-point)) + ;; On the closing quote -- move past it & flash. + (begin (set-current-point! (mark1+ (current-point))) + (flash-sexp-match)) + ;; Elsewhere in a string: insert escaped. + (begin (insert-char #\\ ) + (insert-char #\space)))) + ((parse-state-in-comment? state) + (insert-char #\" )) + ((not (mark-right-char-quoted? (current-point))) + (insert-sexp-pair #\" #\" 0)))))) + +(define-command paredit-backslash + "Insert a backslash followed by a character to escape." + () + (lambda () + (let ((state (current-parse-state))) + (insert-char #\\ ) + (if (not (parse-state-in-comment? state)) + (let ((char #f)) + (dynamic-wind ;++ What happens if this gets + (lambda () unspecific) ;++ used in a recursive edit? + (lambda () + (set! char (prompt-for-char "Character to escape"))) + (lambda () + (if (and char (not (char=? char #\rubout))) + (insert-char char) + (delete-left-char))))))))) + +(define-command paredit-newline + "Insert a newline and indent. +This is like `newline-and-indent', but it not only indents the line + that the point is on but also the S-expression following the point, + if there is one. +Move forward one character first if on an escaped character. +If in a string, just insert a literal newline." + () + (lambda () + (let ((state (current-parse-state))) + (cond ((parse-state-in-string? state) + (insert-newline)) + (else + (let ((point (current-point))) + (if (and (not (parse-state-in-string? state)) + (mark-right-char-quoted? point)) + (set-current-point! (mark1+ point)))) + (delete-horizontal-space) + (insert-newline) + (lisp-indent-line-and-sexp)))))) + +(define-command paredit-forward-delete + "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. +With a prefix argument, simply delete a character forward, without + regard for delimiter balancing. This is useful when the buffer has + entered a structurally inconsistent state which paredit is unable to + cope with." + "P" + (lambda (argument) + (let ((point (current-point))) + (if (or (command-argument-value argument) + (group-end? point)) + ((ref-command delete-char) #f) + (let ((state (current-parse-state)) + (right (mark-right-char point))) + (cond ((parse-state-in-string? state) + (paredit-forward-delete-in-string point state)) + ((parse-state-in-comment? state) + (delete-right-char point)) + ((mark-right-char-quoted? point) + ;; Escape -- delete both characters. + (delete-string (mark-1+ point) + (mark1+ point))) + ((char=? right #\\ ) + ;; Ditto. + (delete-string (mark+ point 2) point)) + ((let ((syn (char-syntax right))) + (or (char=? syn #\( ) + (char=? syn #\" ))) + ;; Enter into an S-expression forward. + (set-current-point! (mark1+ point))) + ((and (not (mark-right-char-quoted? + (mark-1+ point))) + (char=? (char-syntax right) + #\) ) + (char=? (mark-left-char point) + (char-matching-paren right))) + ;; Empty list -- delete both delimiters. + (delete-string (mark-1+ point) + (mark1+ point))) + ;; Just delete a single character, if it's not a + ;; closing parenthesis. + ((not (char=? (char-syntax right) #\) )) + (delete-right-char point)))))))) + +(define (paredit-forward-delete-in-string point state) + (let ((before (mark-1+ point)) + (after (mark1+ point))) + (cond ((not (mark= after (parse-state-end-of-sexp state))) + ;; If it's not the close-quote, it's safe to delete. But + ;; first handle the case that we're in a string escape. + (cond ((mark-within-string-escape? point) + ;; We're right after the backslash, so delete one + ;; character backward (the backslash) and one + ;; character forward (the escaped character). + (delete-string before after)) + ((mark-within-string-escape? after) + ;; A string escape starts here, so delete both + ;; characters forward. + (delete-string point (mark1+ after))) + (else + ;; Otherwise, just delete a single character. + (delete-right-char point)))) + ((mark= before (parse-state-start-of-sexp state)) + ;; If it is the close-quote, delete only if we're also + ;; right past the open-quote (i.e. it's empty), and then + ;; delete both quotes. Otherwise refuse to delete it. + (delete-string before after))))) + +(define-command paredit-backward-delete + "Delete a character backward or move backward over a delimiter. +If on a closing 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. +With a prefix argument, simply delete a character backward, without + regard for delimiter balancing, and possibly untabify. This is + useful when the buffer has entered a structurally inconsistent state + which paredit is unable to cope with." + "P" + (lambda (argument) + (let ((point (current-point))) + (if (or (command-argument-value argument) + (group-start? point)) + ((ref-command backward-delete-char-untabify) #f) + (let ((state (current-parse-state)) + (left (mark-left-char point))) + (cond ((parse-state-in-string? state) + (paredit-backward-delete-in-string point state)) + ((parse-state-in-comment? state) + ((ref-command backward-delete-char-untabify) #f)) + ((mark-right-char-quoted? point) + ;; Escape -- delete both characters. + (delete-string (mark-1+ point) + (mark1+ point))) + ((mark-left-char-quoted? point) + ;; Ditto. + (delete-string (mark- point 2) point)) + ((let ((syn (char-syntax left))) + (or (char=? syn #\) ) + (char=? syn #\" ))) + ;; Enter into an S-expression backward. + (set-current-point! (mark-1+ point))) + ((and (char=? (char-syntax left) #\( ) + (char=? (mark-right-char point) + (char-matching-paren left))) + ;; Empty list -- delete both delimiters. + (delete-string (mark-1+ point) + (mark1+ point))) + ;; Delete it only on the condition that it's not an + ;; opening parenthesis. + ((not (char=? (char-syntax left) #\( )) + ((ref-command backward-delete-char-untabify) #f)))))))) + +(define (paredit-backward-delete-in-string point state) + (let ((before (mark-1+ point)) + (after (mark1+ point))) + (cond ((not (mark= before (parse-state-start-of-sexp state))) + ;; If it's not the open-quote, it's safe to delete, but we + ;; still must be careful with escapes. + (cond ((mark-within-string-escape? point) + (delete-string before after)) + ((mark-within-string-escape? before) + (delete-string (mark-1+ before) point)) + (else + (delete-left-char point)))) + ((mark= after (parse-state-end-of-sexp state)) + ;; If it is the open-quote, delete only if we're also right + ;; past the close-quote (i.e. it's empty), and then delete + ;; both quotes. Otherwise we refuse to delete it. + (delete-string before after))))) + +(define-command paredit-kill + "Kill a line as if with `kill-line', but respect 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 on the line after the + point." + "P" + (lambda (argument) + (if (command-argument-value argument) + ((ref-command kill-line) #f) + (let ((state (current-parse-state)) + (point (current-point))) + (cond ((parse-state-in-string? state) + (paredit-kill-line-in-string point)) + ((or (parse-state-in-comment? state) + (let* ((eol (line-end point 0)) + (next + (skip-whitespace-forward point eol))) + (or (mark= next eol) + (char=? (mark-right-char next) + #\; )))) + ((ref-command kill-line) #f)) + (else + (paredit-kill-sexps-on-line point))))))) + +(define (paredit-kill-line-in-string point) + (let ((eol (line-end point 0))) + (cond ((mark= (skip-whitespace-forward point eol) + eol) + ((ref-command kill-line) #f)) + (else + (let ((beginning (if (mark-within-string-escape? point) + (mark-1+ point) + point))) + (let loop ((mark beginning)) + (if (or (mark= mark eol) + (char=? (mark-right-char mark) + #\" )) + (kill-string beginning mark) + (loop (mark+ mark + (if (char=? (mark-left-char mark) + #\\ ) + 2 + 1)))))))))) + +(define (paredit-kill-sexps-on-line point) + (let* ((beginning (if (mark-right-char-quoted? point) + (mark1+ point) ; Don't break a line in a + point)) ; character literal. + (eol (line-end beginning 0)) + (kill-to (lambda (end) + (kill-string beginning end)))) + (let loop ((mark beginning)) + (cond ((or (group-end? mark) + (not (mark= (line-end mark 0) eol))) + (kill-to mark)) + ((forward-one-sexp mark) + => (lambda (sexp-end-mark) + (cond ((backward-one-sexp sexp-end-mark) + => (lambda (sexp-start-mark) + ;; Only if it starts on the same line + ;; will we include it in what we kill. + (if (mark= (line-end sexp-start-mark 0) + eol) + (loop sexp-end-mark) + (kill-to mark)))) + (else (kill-to mark))))) + ((forward-up-one-list mark) + => (lambda (after-close) + (kill-to (if (mark= (line-end after-close 0) + eol) + (mark-1+ after-close) + eol)))) + (else + (kill-to mark)))))) + +;;;; Cursor and Screen Movement Commands on S-expressions + +(define (paredit-movement-command move-sexp move-char move-up) + (lambda () + (set-current-point! + (let ((point (current-point))) + (cond ((move-sexp point)) + ((parse-state-in-string? (current-parse-state)) + (move-char point)) + ((move-up point)) + (else + (editor-error "Unable to move."))))))) + +(define-command paredit-forward + "Move forward an S-expression, or up an S-expression forward. +If there are no more S-expressions in this one before the closing + delimiter, move past that closing delimiter; otherwise, move forward + over the S-expression following the point." + () + (paredit-movement-command forward-one-sexp + mark1+ + forward-up-one-list)) + +(define-command paredit-backward + "Move backward an S-expression, or up an S-expression backward. +If there are no more S-expressions in this one after the opening + delimiter, move past that opening delimiter; otherwise, move + backward over the S-expression preceding the point." + () + (paredit-movement-command backward-one-sexp + mark-1+ + backward-up-one-list)) + +(define-command paredit-recentre-on-sexp + "Recentre the screen on the S-expression following the point. +With a prefix argument N, encompass all N S-expressions forward." + "p" + (lambda (n) + (let* ((end-mark (forward-sexp (current-point) n 'ERROR)) + (start-mark (backward-sexp end-mark n 'ERROR)) + (centre-offset (quotient (count-lines start-mark end-mark) + 2))) + (set-current-point! (line-start start-mark centre-offset)) + ((ref-command recenter) #f)))) + +;;;; Wrappage, splicage, & raisage + +(define-command paredit-wrap-sexp + "Wrap the following S-expression in a list. +If a prefix argument N is given, wrap N S-expressions. +Automatically indent the newly wrapped S-expression. +As a special case, if the point is at the end of a list, simply insert + a pair of parentheses." + "p" + (lambda (n) + (insert-sexp-pair #\( #\) + (if (forward-sexp (current-point) n #f) + n + 0)) + (lisp-indent-sexp + (or (backward-up-one-list (current-point)) + (error "Wrappage bogosity. Please inform TRC."))))) + +(define-command paredit-raise-sexp + "Raise the following S-expression in a tree, deleting its siblings. +With a prefix argument N, raise the following N S-expressions. If N + is negative, raise the preceding N S-expressions." + "p" + (lambda (n) + ;; I have very carefully selected where to use {FOR,BACK}WARD-SEXP + ;; with arguments 1 & ERROR and {FOR,BACKWARD}-ONE-SEXP here, so + ;; that the error is signalled initially and then not checked + ;; redundantly later. + ;++ This should be verified. + (let* ((point (current-point)) + (mark (forward-sexp (current-point) n 'ERROR)) + (sexps (if (negative? n) + (extract-string mark + (forward-one-sexp + (backward-one-sexp point))) + (extract-string (backward-one-sexp + (forward-one-sexp point)) + mark))) + (before-encloser (mark-temporary-copy + (backward-up-list point 1 'ERROR)))) + (delete-string before-encloser + (forward-sexp before-encloser 1 'ERROR)) + (insert-string sexps before-encloser) + (let loop ((n n) (mark before-encloser)) + (if (positive? n) + (let ((after (forward-one-sexp mark))) + (set-current-point! (backward-one-sexp after)) + (lisp-indent-line #f) + (lisp-indent-sexp (current-point)) + (loop (- n 1) after)))) + (set-current-point! before-encloser)))) + +(define-command paredit-splice-sexp + "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. +With two prefix arguments as in `C-u C-u', kill all S-expressions + forward in the current list before splicing all S-expressions + backward into the enclosing list. +With a numerical prefix argument N, kill N S-expressions backward in + the current list before splicing the remaining S-expressions into the + enclosing list. If N is negative, kill forward." + "P" + (lambda (argument) + (if argument (paredit-kill-surrounding-sexps-for-splice argument)) + (let* ((before-open (backward-up-list (current-point) 1 'ERROR)) + (before-close + (mark-1+ (forward-sexp before-open 1 'ERROR)))) + (delete-right-char before-close) + (delete-right-char before-open) + (with-current-point before-open + (lambda () + (paredit-reindent-splicage argument)))))) + +(define (paredit-kill-surrounding-sexps-for-splice argument) + (cond ((command-argument-multiplier-only? argument) + (let ((loop (lambda (mark-end? advance-one-sexp) + (let ((point-a (current-point))) + (let loop ((point-b point-a)) + (define (win) (kill-string point-a point-b)) + (cond ((mark-end? point-b) (win)) + ((advance-one-sexp point-b) => loop) + (else (win))))))) + (value (command-argument-numeric-value argument))) + (if (= value 4) ;One C-u + (loop group-start? backward-one-sexp) + (loop group-end? forward-one-sexp)))) + ((exact-integer? argument) + (let* ((point (current-point)) + (mark (backward-sexp point argument 'ERROR))) + (kill-string point mark))) + (else + (error "Bizarre prefix argument to PAREDIT-SPLICE:" + argument)))) + +(define (paredit-reindent-splicage argument) + (cond ((backward-up-list (current-point) 1 #f) + => lisp-indent-sexp) + ((not (exact-integer? argument)) + unspecific) + ((positive? argument) + (lisp-indent-line #f) + (lisp-indent-sexp (current-point)) + (if (> argument 1) + (save-excursion + (lambda () + (let loop ((n n)) + (lisp-indent-line #f) + (modify-current-point! + (lambda (point) + (lisp-indent-sexp point) + (forward-one-sexp point))) + (let ((m (- n 1))) + (if (positive? m) + (loop m)))))))) + ((negative? n) + (save-excursion + (lambda () + (let loop ((n n)) + (cond ((not (zero? n)) + (modify-current-point! backward-one-sexp) + (lisp-indent-line #f) + (lisp-indent-sexp (current-point)) + (loop (+ n 1)))))))))) + +;;;; Miscellaneous Utilities + +(define (current-parse-state #!optional point) + (let ((point (if (default-object? point) + (current-point) + point))) + (parse-partial-sexp (or (this-definition-start point) + (buffer-start (current-buffer))) + point))) + +;++ These are wrong, but, argh, I don't think Edwin preserves enough +;++ information to make them right. + +(define (parse-state-end-of-sexp state) + (forward-one-sexp (forward-one-sexp (parse-state-last-sexp state)))) + +(define (parse-state-start-of-sexp state) + (backward-one-sexp (parse-state-end-of-sexp state))) + +(define (insert-sexp-pair open close sexps #!optional mark) + + (define (insert-space end? mark) + (if (and (not (if end? + (group-end? mark) + (group-start? mark))) + (memv (char-syntax (if end? + (mark-right-char mark) + (mark-left-char mark))) + (cons (if end? #\( #\) ) + '(#\\ ; escape + #\w ; word constituent + #\_ ; symbol constituent + #\")))) ; string quote + (begin (insert-char #\space mark) + (mark1+ mark)) + mark)) + + (let* ((start (mark-temporary-copy (if (default-object? mark) + (current-point) + mark))) + (before (insert-space #f start))) + (insert-char open before) + (let ((point (mark1+ before))) + (let ((after (forward-sexp point sexps 'ERROR))) + (insert-char close after) + (insert-space #t (mark1+ after))) + (set-current-point! point)))) + +(define (insert-newline-preserving-comment #!optional mark) + (let ((mark (if (default-object? mark) (current-point) mark))) + (cond ((line-margin-comment-region mark) + => (lambda (region) + (mark-permanent! mark) + (let* ((before-semi (region-start region)) + (bol (line-start before-semi 0)) + (column (region-count-chars + (make-region bol before-semi))) + (comment (extract-and-delete-string + before-semi + (region-end region)))) + (delete-horizontal-space before-semi) + (let ((copy (mark-temporary-copy mark))) + (insert-newline mark) + (indent-to column 0 copy) + (insert-string comment (line-end copy 0)))))) + (else + (insert-newline mark))))) + +;;; This assumes that POINT is before the comment on the line, if there +;;; is a comment. This assumption may be flawed for general use, but +;;; it is guaranteed by paredit's use of this procedure. + +(define (line-margin-comment-region #!optional point) + (let* ((point (if (default-object? point) + (current-point) + point)) + (eol (line-end point 0))) + (let loop ((point point) + (state (current-parse-state point))) + (cond ((char-search-forward #\; point eol) + => (lambda (after-semi) + (let ((state* (parse-partial-sexp point after-semi + #f #f + state))) + (if (or (mark-left-char-quoted? after-semi) + (parse-state-in-string? state*)) + (loop after-semi state*) + (make-region (mark-1+ after-semi) + eol))))) + (else #f))))) + +(define (lisp-indent-line-and-sexp) + (lisp-indent-line #f) + (let ((point (current-point))) + (if (forward-one-sexp point) + (lisp-indent-sexp point)))) + +;;; In paredit.el, the ABSOLUTELY? argument determined whether or not +;;; to override the BLINK-MATCHING-PAREN variable, because in some +;;; contexts SHOW-PAREN-MODE suffices for the purpose; however, Edwin +;;; has no such variable or SHOW-PAREN-MODE, but I'd like to make it +;;; easy to support them later on. + +(define (flash-sexp-match #!optional absolutely? point) + absolutely? + (mark-flash (backward-one-sexp (if (default-object? point) + (current-point) + point)) + 'RIGHT)) + +(define (char-matching-paren char) + ;++ This is a hideous kludge. Why is it necessary? There must be + ;++ something built-in that does this. + (string-ref (char-syntax->string + (get-char-syntax (ref-variable syntax-table) + char)) + 1)) + +;;; This assumes that MARK is already in a string. + +(define (mark-within-string-escape? mark) + (let loop ((flag #f) (mark mark)) + (if (char=? (mark-left-char mark) + #\\) + (loop (not flag) (mark-1+ mark)) + flag))) + +(define (skip-whitespace-forward #!optional start end) + (skip-chars-forward (char-set->string char-set:whitespace) + start + end)) + +(define (char-set->string char-set) + (list->string (char-set-members char-set))) + +(define (undo-record-point! #!optional buffer) + (let ((group (buffer-group (if (default-object? buffer) + (current-buffer) + buffer)))) + (set-group-undo-data! group + (cons (mark-index (group-point group)) + (group-undo-data group))))) + +(define (modify-current-point! modifier) + (set-current-point! (modifier (current-point)))) + +;;; Edwin Variables: +;;; outline-pattern: "^ \n;;;;+" +;;; End: