1#| -*-Scheme-*- 2 3This code is written by Taylor R. Campbell and placed in the Public 4Domain. All warranties are disclaimed. 5 6|# 7 8;;;; Paredit: Parenthesis-Editing Minor Mode (based on paredit.el) 9 10(declare (usual-integrations)) 11 12(define-command paredit-mode 13 "Toggle pseudo-structural editing of Lisp code. 14With a prefix argument, enable paredit mode if the argument is 15 positive, and disable paredit mode if not." 16 "P" 17 (lambda (argument) 18 (let ((mode (ref-mode-object paredit))) 19 (if (if argument 20 (positive? (command-argument-value argument)) 21 (not (current-minor-mode? mode))) 22 (enable-current-minor-mode! mode) 23 (disable-current-minor-mode! mode))))) 24 25(define-minor-mode paredit "Paredit" 26 "Minor mode for pseudo-structurally editing Lisp code. 27 28\\{paredit}") 29 30(for-each (lambda (key) 31 (define-key 'paredit (car key) (cadr key))) 32 '( 33 ;; Insertion commands 34 (#\( paredit-open-list) 35 (#\) paredit-close-list-and-newline) 36 (#\M-\) paredit-close-list) 37 (#\M-\" paredit-close-string-and-newline) 38 (#\" paredit-doublequote) 39 (#\\ paredit-backslash) 40 (#\return paredit-newline) ; This defies the convention, 41 (#\C-j newline) ; but I prefer it, and you can 42 ; customize it yourself anyway. 43 ;; Killing & deleting 44 (#\C-d paredit-forward-delete) 45 (#\rubout paredit-backward-delete) 46 (#\C-k paredit-kill) 47 48 ;; Movement & navigation 49 (#\C-M-f paredit-forward) 50 (#\C-M-b paredit-backward) 51;;; (#\C-M-u backward-up-list) ; These two are built-in. 52;;; (#\C-M-d down-list) 53 (#\C-M-p backward-down-list) 54 (#\C-M-n up-list) 55 ((#\C-c #\C-M-l) paredit-recentre-on-sexp) 56 57 ;; Depth-changing commands 58 (#\M-\( paredit-wrap-sexp) 59 (#\M-r paredit-raise-sexp) 60 (#\M-s paredit-splice-sexp) ;++ This conflicts with M-s 61 ;++ for STEP-DEFUN. Hmmmm. 62 63 ;; Splitting and Joining 64 (#\M-S paredit-split-sexp) 65 (#\M-J paredit-join-sexps) 66 )) 67 68;;;; Basic Editing Commands 69 70(define-command paredit-open-list 71 "Insert a balanced round bracket parenthesis pair. 72With a prefix argument N, put the closing round bracket after N 73 S-expressions forward. 74If in string or comment, inserts a single opening round bracket. 75If in a character literal, does nothing. This prevents accidentally 76 changing what was in the character literal to a meaningful delimiter 77 unintentionally." 78 "P" 79 (let ((open-list 80 (lambda (argument) 81 (insert-sexp-pair #\( #\) 82 (or (command-argument-value argument) 83 0))))) 84 (lambda (argument) 85 (if (group-start? (current-point)) 86 (open-list #f) 87 (let ((state (current-parse-state))) 88 (cond ((or (parse-state-in-string? state) 89 (parse-state-in-comment? state)) 90 (insert-char #\( )) 91 ((not (mark-right-char-quoted? (current-point))) 92 (open-list argument)))))))) 93 94(define-command paredit-close-list 95 "Move past the closing delimiter of the list the point is on. 96Delete all extraneous space before the closing delimiter, but do not 97 move it past comments between it and the point. 98If in a string or comment, insert a single closing round bracket. 99If in a character literal, do nothing. This prevents accidentally 100 changing what was in the character literal to a meaningful delimiter 101 unintentionally." 102 () 103 (lambda () 104 (let ((point (current-point))) 105 (if (group-start? point) 106 (editor-failure "No list to close at buffer start.") 107 (let ((state (current-parse-state))) 108 (cond ((or (parse-state-in-string? state) 109 (parse-state-in-comment? state)) 110 (insert-char #\) )) 111 ((not (mark-right-char-quoted? point)) 112 (paredit-move-past-close-and-reindent point state) 113 (flash-sexp-match)))))))) 114 115(define-command paredit-close-list-and-newline 116 "Move past close of the current list, insert a newline, & indent. 117If in a string or comment, insert a single closing round bracket. 118If in a character literal, do nothing. This prevents accidentally 119 changing what was in the character literal to a meaningful delimiter 120 unintentionally." 121 () 122 (lambda () 123 (let ((point (current-point))) 124 (if (group-start? point) 125 (editor-failure "No list to close at buffer start.") 126 (let ((state (current-parse-state))) 127 (cond ((or (parse-state-in-string? state) 128 (parse-state-in-comment? state)) 129 (insert-char #\) )) 130 (else 131 (paredit-move-past-close-and-reindent 132 (if (mark-right-char-quoted? point) 133 (mark1+ point) 134 point) 135 state) 136 (insert-newline-preserving-comment) 137 (lisp-indent-line-and-sexp) 138 (flash-sexp-match #t)))))))) 139 140(define (paredit-move-past-close-and-reindent mark state) 141 (cond ((forward-up-one-list mark) 142 => (lambda (after-close) 143 (undo-record-point!) 144 (set-current-point! after-close) 145 (let loop ((before-close (mark-1+ after-close))) 146 (if (mark= (horizontal-space-end 147 (line-start before-close 0)) 148 before-close) 149 ;; The closing delimiter is the first thing on the 150 ;; line. If the previous line ends in a comment, 151 ;; we stop here; otherwise, we go on. 152 (let ((end-of-prev (line-end before-close -1)) 153 (location (parse-state-location state))) 154 (cond ((and (not (mark<= end-of-prev location)) 155 (parse-state-in-comment? 156 (parse-partial-sexp location 157 end-of-prev 158 #f #f 159 state))) 160 ;; Nothing more to be done, so just 161 ;; indent the line we're on (which has 162 ;; the closing delimiter). 163 (lisp-indent-line #f)) 164 (else 165 ;; More to delete. 166 (delete-string end-of-prev before-close) 167 (loop end-of-prev)))) 168 ;; We've reached our goal, though there might be 169 ;; some indentation between the closing delimiter 170 ;; and where we want it to be. We must take care, 171 ;; though, to preserve whitespace characters. 172 (let* ((mark 173 (horizontal-space-start before-close)) 174 (escaped 175 (and (mark-right-char-quoted? mark) 176 (mark-right-char mark)))) 177 (delete-horizontal-space before-close) 178 (if escaped 179 (insert-char escaped mark))))))) 180 (else 181 (editor-error "No closing delimiter to move over.")))) 182 183(define-command paredit-close-string-and-newline 184 "Move to the end of the string, insert a newline, and indent. 185If not in a string, act as `paredit-doublequote'." 186 () 187 (lambda () 188 (let ((state (current-parse-state))) 189 (if (not (parse-state-in-string? state)) 190 ((ref-command paredit-doublequote)) 191 (let ((after-string (parse-state-end-of-sexp state))) 192 (set-current-point! after-string) 193 (insert-newline) 194 (lisp-indent-line-and-sexp) 195 (flash-sexp-match #f after-string)))))) 196 197(define-command paredit-doublequote 198 "Insert a pair of double-quotes. 199Inside a comment, insert a literal double-quote. 200At the end of a string, move past the closing double-quote. 201In the middle of a string, insert a backslash-escaped double-quote. 202If in a character literal, do nothing. This prevents accidentally 203 changing what was in the character literal to a meaningful delimiter 204 unintentionally." 205 () 206 (lambda () 207 (let ((state (current-parse-state))) 208 (cond ((parse-state-in-string? state) 209 (if (mark= (mark-1+ (parse-state-end-of-sexp state)) 210 (current-point)) 211 ;; On the closing quote -- move past it & flash. 212 (begin (set-current-point! (mark1+ (current-point))) 213 (flash-sexp-match)) 214 ;; Elsewhere in a string: insert escaped. 215 (begin (insert-char #\\ ) 216 (insert-char #\")))) 217 ((parse-state-in-comment? state) 218 (insert-char #\" )) 219 ((not (mark-right-char-quoted? (current-point))) 220 (insert-sexp-pair #\" #\" 0)))))) 221 222(define-command paredit-backslash 223 "Insert a backslash followed by a character to escape." 224 () 225 (lambda () 226 (let ((state (current-parse-state))) 227 (insert-char #\\ ) 228 (if (not (parse-state-in-comment? state)) 229 (let ((char #f)) 230 (dynamic-wind ;++ What happens if this gets 231 (lambda () unspecific) ;++ used in a recursive edit? 232 (lambda () 233 (set! char (prompt-for-char "Character to escape"))) 234 (lambda () 235 (if (and char (not (char=? char #\rubout))) 236 (insert-char char) 237 (delete-left-char))))))))) 238 239(define-command paredit-newline 240 "Insert a newline and indent. 241This is like `newline-and-indent', but it not only indents the line 242 that the point is on but also the S-expression following the point, 243 if there is one. 244Move forward one character first if on an escaped character. 245If in a string, just insert a literal newline." 246 () 247 (lambda () 248 (let ((state (current-parse-state))) 249 (cond ((parse-state-in-string? state) 250 (insert-newline)) 251 (else 252 (let ((point (current-point))) 253 (if (and (not (parse-state-in-string? state)) 254 (mark-right-char-quoted? point)) 255 (set-current-point! (mark1+ point)))) 256 (delete-horizontal-space) 257 (insert-newline) 258 (lisp-indent-line-and-sexp)))))) 259 260(define-command paredit-forward-delete 261 "Delete a character forward or move forward over a delimiter. 262If on an opening S-expression delimiter, move forward into the 263 S-expression. 264If on a closing S-expression delimiter, refuse to delete unless the 265 S-expression is empty, in which case delete the whole S-expression. 266With a prefix argument, simply delete a character forward, without 267 regard for delimiter balancing. This is useful when the buffer has 268 entered a structurally inconsistent state which paredit is unable to 269 cope with." 270 "P" 271 (lambda (argument) 272 (let ((point (current-point))) 273 (if (or (command-argument-value argument) 274 (group-end? point)) 275 ((ref-command delete-char) #f) 276 (let ((state (current-parse-state)) 277 (right (mark-right-char point))) 278 (cond ((parse-state-in-string? state) 279 (paredit-forward-delete-in-string point state)) 280 ((parse-state-in-comment? state) 281 (delete-right-char point)) 282 ((mark-right-char-quoted? point) 283 ;; Escape -- delete both characters. 284 (delete-string (mark-1+ point) 285 (mark1+ point))) 286 ((char=? right #\\ ) 287 ;; Ditto. 288 (delete-string (mark+ point 2) point)) 289 ((let ((syn (char-syntax right))) 290 (or (char=? syn #\( ) 291 (char=? syn #\" ))) 292 ;; Enter into an S-expression forward. 293 (set-current-point! (mark1+ point))) 294 ((and (not (group-start? point)) 295 (not (mark-right-char-quoted? 296 (mark-1+ point))) 297 (char=? (char-syntax right) 298 #\) ) 299 (char=? (mark-left-char point) 300 (char-matching-paren right))) 301 ;; Empty list -- delete both delimiters. 302 (delete-string (mark-1+ point) 303 (mark1+ point))) 304 ;; Just delete a single character, if it's not a 305 ;; closing parenthesis. 306 ((not (char=? (char-syntax right) #\) )) 307 (delete-right-char point)))))))) 308 309(define (paredit-forward-delete-in-string point state) 310 (let ((before (mark-1+ point)) 311 (after (mark1+ point))) 312 (cond ((not (mark= after (parse-state-end-of-sexp state))) 313 ;; If it's not the close-quote, it's safe to delete. But 314 ;; first handle the case that we're in a string escape. 315 (cond ((mark-within-string-escape? point) 316 ;; We're right after the backslash, so delete one 317 ;; character backward (the backslash) and one 318 ;; character forward (the escaped character). 319 (delete-string before after)) 320 ((mark-within-string-escape? after) 321 ;; A string escape starts here, so delete both 322 ;; characters forward. 323 (delete-string point (mark1+ after))) 324 (else 325 ;; Otherwise, just delete a single character. 326 (delete-right-char point)))) 327 ((mark= before (parse-state-start-of-sexp state)) 328 ;; If it is the close-quote, delete only if we're also 329 ;; right past the open-quote (i.e. it's empty), and then 330 ;; delete both quotes. Otherwise refuse to delete it. 331 (delete-string before after))))) 332 333(define-command paredit-backward-delete 334 "Delete a character backward or move backward over a delimiter. 335If on a closing S-expression delimiter, move backward into the 336 S-expression. 337If on an opening S-expression delimiter, refuse to delete unless the 338 S-expression is empty, in which case delete the whole S-expression. 339With a prefix argument, simply delete a character backward, without 340 regard for delimiter balancing, and possibly untabify. This is 341 useful when the buffer has entered a structurally inconsistent state 342 which paredit is unable to cope with." 343 "P" 344 (lambda (argument) 345 (let ((point (current-point))) 346 (if (or (command-argument-value argument) 347 (group-start? point)) 348 ((ref-command backward-delete-char-untabify) #f) 349 (let ((state (current-parse-state)) 350 (left (mark-left-char point))) 351 (cond ((parse-state-in-string? state) 352 (paredit-backward-delete-in-string point state)) 353 ((parse-state-in-comment? state) 354 ((ref-command backward-delete-char-untabify) #f)) 355 ((mark-right-char-quoted? point) 356 ;; Escape -- delete both characters. 357 (delete-string (mark-1+ point) 358 (mark1+ point))) 359 ((mark-left-char-quoted? point) 360 ;; Ditto. 361 (delete-string (mark- point 2) point)) 362 ((let ((syn (char-syntax left))) 363 (or (char=? syn #\) ) 364 (char=? syn #\" ))) 365 ;; Enter into an S-expression backward. 366 (set-current-point! (mark-1+ point))) 367 ((and (char=? (char-syntax left) #\( ) 368 (char=? (mark-right-char point) 369 (char-matching-paren left))) 370 ;; Empty list -- delete both delimiters. 371 (delete-string (mark-1+ point) 372 (mark1+ point))) 373 ;; Delete it only on the condition that it's not an 374 ;; opening parenthesis. 375 ((not (char=? (char-syntax left) #\( )) 376 ((ref-command backward-delete-char-untabify) #f)))))))) 377 378(define (paredit-backward-delete-in-string point state) 379 (let ((before (mark-1+ point)) 380 (after (mark1+ point))) 381 (cond ((not (mark= before (parse-state-start-of-sexp state))) 382 ;; If it's not the open-quote, it's safe to delete, but we 383 ;; still must be careful with escapes. 384 (cond ((mark-within-string-escape? point) 385 (delete-string before after)) 386 ((mark-within-string-escape? before) 387 (delete-string (mark-1+ before) point)) 388 (else 389 (delete-left-char point)))) 390 ((mark= after (parse-state-end-of-sexp state)) 391 ;; If it is the open-quote, delete only if we're also right 392 ;; past the close-quote (i.e. it's empty), and then delete 393 ;; both quotes. Otherwise we refuse to delete it. 394 (delete-string before after))))) 395 396(define-command paredit-kill 397 "Kill a line as if with `kill-line', but respect delimiters. 398In a string, act exactly as `kill-line' but do not kill past the 399 closing string delimiter. 400On a line with no S-expressions on it starting after the point or 401 within a comment, act exactly as `kill-line'. 402Otherwise, kill all S-expressions that start on the line after the 403 point." 404 "P" 405 (lambda (argument) 406 (if (command-argument-value argument) 407 ((ref-command kill-line) #f) 408 (let ((state (current-parse-state)) 409 (point (current-point))) 410 (cond ((parse-state-in-string? state) 411 (paredit-kill-line-in-string point)) 412 ((or (parse-state-in-comment? state) 413 (let* ((eol (line-end point 0)) 414 (next 415 (skip-whitespace-forward point eol))) 416 (or (mark= next eol) 417 (char=? (mark-right-char next) 418 #\; )))) 419 ((ref-command kill-line) #f)) 420 (else 421 (paredit-kill-sexps-on-line point))))))) 422 423(define (paredit-kill-line-in-string point) 424 (let ((eol (line-end point 0))) 425 (cond ((mark= (skip-whitespace-forward point eol) 426 eol) 427 ((ref-command kill-line) #f)) 428 (else 429 (let ((beginning (if (mark-within-string-escape? point) 430 (mark-1+ point) 431 point))) 432 (let loop ((mark beginning)) 433 (if (or (mark= mark eol) 434 (char=? (mark-right-char mark) 435 #\" )) 436 (kill-string beginning mark) 437 (loop (mark+ mark 438 (if (char=? (mark-left-char mark) 439 #\\ ) 440 2 441 1)))))))))) 442 443(define (paredit-kill-sexps-on-line point) 444 (let* ((beginning (if (mark-right-char-quoted? point) 445 (mark1+ point) ; Don't break a line in a 446 point)) ; character literal. 447 (eol (line-end beginning 0)) 448 (kill-to (lambda (end) 449 (kill-string beginning end)))) 450 (let loop ((mark beginning)) 451 (cond ((or (group-end? mark) 452 (not (mark= (line-end mark 0) eol))) 453 (kill-to mark)) 454 ((forward-one-sexp mark) 455 => (lambda (sexp-end-mark) 456 (cond ((backward-one-sexp sexp-end-mark) 457 => (lambda (sexp-start-mark) 458 ;; Only if it starts on the same line 459 ;; will we include it in what we kill. 460 (if (mark= (line-end sexp-start-mark 0) 461 eol) 462 (loop sexp-end-mark) 463 (kill-to mark)))) 464 (else (kill-to mark))))) 465 ((forward-up-one-list mark) 466 => (lambda (after-close) 467 (kill-to (if (mark= (line-end after-close 0) 468 eol) 469 (mark-1+ after-close) 470 eol)))) 471 (else 472 (kill-to mark)))))) 473 474;;;; Cursor and Screen Movement Commands on S-expressions 475 476(define (paredit-movement-command move-sexp move-char move-up) 477 (lambda () 478 (set-current-point! 479 (let ((point (current-point))) 480 (cond ((move-sexp point)) 481 ((parse-state-in-string? (current-parse-state)) 482 (move-char point)) 483 ((move-up point)) 484 (else 485 (editor-error "Unable to move."))))))) 486 487(define-command paredit-forward 488 "Move forward an S-expression, or up an S-expression forward. 489If there are no more S-expressions in this one before the closing 490 delimiter, move past that closing delimiter; otherwise, move forward 491 over the S-expression following the point." 492 () 493 (paredit-movement-command forward-one-sexp 494 mark1+ 495 forward-up-one-list)) 496 497(define-command paredit-backward 498 "Move backward an S-expression, or up an S-expression backward. 499If there are no more S-expressions in this one after the opening 500 delimiter, move past that opening delimiter; otherwise, move 501 backward over the S-expression preceding the point." 502 () 503 (paredit-movement-command backward-one-sexp 504 mark-1+ 505 backward-up-one-list)) 506 507(define-command paredit-recentre-on-sexp 508 "Recentre the screen on the S-expression following the point. 509With a prefix argument N, encompass all N S-expressions forward." 510 "p" 511 (lambda (n) 512 (let* ((end-mark (forward-sexp (current-point) n 'ERROR)) 513 (start-mark (backward-sexp end-mark n 'ERROR)) 514 (centre-offset (quotient (count-lines start-mark end-mark) 515 2))) 516 (set-current-point! (line-start start-mark centre-offset)) 517 ((ref-command recenter) #f)))) 518 519;;;; Wrappage, splicage, & raisage 520 521(define-command paredit-wrap-sexp 522 "Wrap the following S-expression in a list. 523If a prefix argument N is given, wrap N S-expressions. 524Automatically indent the newly wrapped S-expression. 525As a special case, if the point is at the end of a list, simply insert 526 a pair of parentheses." 527 "p" 528 (lambda (n) 529 (insert-sexp-pair #\( #\) 530 (if (forward-sexp (current-point) n #f) 531 n 532 0)) 533 (lisp-indent-sexp 534 (or (backward-up-one-list (current-point)) 535 (error "Wrappage bogosity. Please inform TRC."))))) 536 537(define-command paredit-raise-sexp 538 "Raise the following S-expression in a tree, deleting its siblings. 539With a prefix argument N, raise the following N S-expressions. If N 540 is negative, raise the preceding N S-expressions." 541 "p" 542 (lambda (n) 543 ;; I have very carefully selected where to use {FOR,BACK}WARD-SEXP 544 ;; with arguments 1 & ERROR and {FOR,BACKWARD}-ONE-SEXP here, so 545 ;; that the error is signalled initially and then not checked 546 ;; redundantly later. 547 ;++ This should be verified. 548 (let* ((point (current-point)) 549 (mark (forward-sexp (current-point) n 'ERROR)) 550 (sexps (if (negative? n) 551 (extract-string mark 552 (forward-one-sexp 553 (backward-one-sexp point))) 554 (extract-string (backward-one-sexp 555 (forward-one-sexp point)) 556 mark))) 557 (before-encloser (mark-temporary-copy 558 (backward-up-list point 1 'ERROR)))) 559 (delete-string before-encloser 560 (forward-sexp before-encloser 1 'ERROR)) 561 (insert-string sexps before-encloser) 562 (let loop ((n n) (mark before-encloser)) 563 (if (positive? n) 564 (let ((after (forward-one-sexp mark))) 565 (set-current-point! (backward-one-sexp after)) 566 (lisp-indent-line #f) 567 (lisp-indent-sexp (current-point)) 568 (loop (- n 1) after)))) 569 (set-current-point! before-encloser)))) 570 571(define-command paredit-splice-sexp 572 "Splice the list that the point is on by removing its delimiters. 573With a prefix argument as in `C-u', kill all S-expressions backward in 574 the current list before splicing all S-expressions forward into the 575 enclosing list. 576With two prefix arguments as in `C-u C-u', kill all S-expressions 577 forward in the current list before splicing all S-expressions 578 backward into the enclosing list. 579With a numerical prefix argument N, kill N S-expressions backward in 580 the current list before splicing the remaining S-expressions into the 581 enclosing list. If N is negative, kill forward." 582 "P" 583 (lambda (argument) 584 (undo-record-point!) 585 (if argument (paredit-kill-surrounding-sexps-for-splice argument)) 586 (let* ((before-open (backward-up-list (current-point) 1 'ERROR)) 587 (before-close 588 (mark-1+ (forward-sexp before-open 1 'ERROR)))) 589 (delete-right-char before-close) 590 (delete-right-char before-open) 591 (with-current-point before-open 592 (lambda () 593 (paredit-reindent-splicage argument)))))) 594 595(define (paredit-kill-surrounding-sexps-for-splice argument) 596 (cond ((command-argument-multiplier-only? argument) 597 (let ((loop (lambda (mark-end? advance-one-sexp) 598 (let ((point-a (current-point))) 599 (let loop ((point-b point-a)) 600 (define (win) (kill-string point-a point-b)) 601 (cond ((mark-end? point-b) (win)) 602 ((advance-one-sexp point-b) => loop) 603 (else (win))))))) 604 (value (command-argument-numeric-value argument))) 605 (if (= value 4) ;One C-u 606 (loop group-start? backward-one-sexp) 607 (loop group-end? forward-one-sexp)))) 608 ((exact-integer? argument) 609 (let* ((point (current-point)) 610 (mark (backward-sexp point argument 'ERROR))) 611 (kill-string point mark))) 612 (else 613 (error "Bizarre prefix argument to PAREDIT-SPLICE:" 614 argument)))) 615 616(define (paredit-reindent-splicage argument) 617 (cond ((backward-up-list (current-point) 1 #f) 618 => lisp-indent-sexp) 619 ((not (exact-integer? argument)) 620 unspecific) 621 ((positive? argument) 622 (lisp-indent-line #f) 623 (lisp-indent-sexp (current-point)) 624 (if (> argument 1) 625 (save-excursion 626 (lambda () 627 (let loop ((n argument)) 628 (lisp-indent-line #f) 629 (modify-current-point! 630 (lambda (point) 631 (lisp-indent-sexp point) 632 (forward-one-sexp point))) 633 (let ((m (- n 1))) 634 (if (positive? m) 635 (loop m)))))))) 636 ((negative? argument) 637 (save-excursion 638 (lambda () 639 (let loop ((n argument)) 640 (cond ((not (zero? n)) 641 (modify-current-point! backward-one-sexp) 642 (lisp-indent-line #f) 643 (lisp-indent-sexp (current-point)) 644 (loop (+ n 1)))))))))) 645 646;;;; Splitting and Joining 647 648(define-command paredit-split-sexp 649 "Split the list or string the point is on in two." 650 () 651 (lambda () 652 (let ((state (current-parse-state))) 653 (cond ((parse-state-in-string? state) 654 (insert-char #\") 655 (save-excursion 656 (lambda () 657 (insert-char #\space) 658 (insert-char #\")))) 659 ((or (parse-state-in-comment? state) 660 (mark-right-char-quoted? (current-point))) 661 (editor-error 662 "Invalid context for S-expression splitting.")) 663 ((let ((point (current-point))) 664 (and (memv (char-syntax (mark-left-char point)) 665 '(#\w #\_)) 666 (memv (char-syntax (mark-right-char point)) 667 '(#\w #\_)))) 668 (save-excursion (lambda () 669 (insert-char #\space)))) 670 (else 671 (undo-record-point!) 672 (split-sexp-at-point)))))) 673 674(define (split-sexp-at-point) 675 (let ((open (backward-up-list (current-point) 1 'ERROR)) 676 (close (forward-up-list (current-point) 1 'ERROR))) 677 (let ((open-char (mark-right-char open)) 678 (close-char (mark-left-char close))) 679 (let ((new-close (cond ((backward-one-sexp (current-point)) 680 => forward-one-sexp) 681 (else (mark1+ open)))) 682 (new-open (cond ((forward-one-sexp (current-point)) 683 => backward-one-sexp) 684 (else (mark-1+ close))))) 685 (if (mark< new-open new-close) ;Can't actually happen... 686 (editor-error ;I guess Democritus was right! 687 "Splitting atom! RUN, before critical mass!!")) 688 (let ((new-close (mark-left-inserting-copy new-close)) 689 (new-open (mark-left-inserting-copy new-open))) 690 (insert-char close-char new-close) 691 (mark-temporary! new-close) 692 (save-excursion 693 (lambda () 694 (if (not (char=? (char-syntax (mark-left-char new-open)) 695 #\space)) 696 (insert-char #\space new-open)) 697 (mark-temporary! new-open) 698 (insert-char open-char new-open) 699 (if (mark/= (line-start (current-point) 0) 700 (line-start new-open 0)) 701 (with-current-point new-open 702 lisp-indent-line-and-sexp) 703 (lisp-indent-sexp new-open))))))))) 704 705(define-command paredit-join-sexps 706 "Join the S-expressions adjacent on either side of the point. 707Both must be lists, strings, or atoms; error if there is mismatch." 708 () 709 (lambda () 710 (let ((state (current-parse-state))) 711 (if (or (parse-state-in-comment? state) 712 (parse-state-in-string? state) ;foo 713 (mark-right-char-quoted? (current-point))) 714 (editor-error "Invalid context for S-expression joining.") 715 (let ((left-point (end-of-sexp-backward (current-point))) 716 (right-point (start-of-sexp-forward (current-point)))) 717 (cond ((mark< right-point left-point) 718 (editor-error "Joining single S-expression.")) 719 ((intervening-text? left-point right-point) 720 (editor-error 721 "S-expressions to join have intervenining text.")) 722 (else 723 (save-excursion 724 (lambda () 725 (join-sexps left-point right-point)))))))))) 726 727(define (join-sexps left-point right-point) 728 (let ((left-syntax (char-syntax (mark-left-char left-point))) 729 (right-syntax (char-syntax (mark-right-char right-point)))) 730 (cond ((and (char=? left-syntax #\)) 731 (char=? right-syntax #\()) 732 (let ((right-point 733 (if (mark/= left-point right-point) 734 right-point 735 (begin (insert-char #\space right-point) 736 (mark1+ right-point))))) 737 (delete-right-char right-point) 738 (delete-left-char left-point)) 739 (lisp-indent-sexp 740 (backward-up-list (current-point) 1 'ERROR))) 741 ((and (char=? left-syntax #\") 742 (char=? right-syntax #\")) 743 (delete-string (mark-1+ left-point) 744 (mark1+ right-point))) 745 ((or (and (memq left-syntax '(#\w #\_)) 746 (memq right-syntax '(#\w #\_)))) 747 ;; Word or symbol 748 (delete-string left-point right-point)) 749 (else 750 (editor-error 751 "Mismatched S-expressions to join."))))) 752 753;;;; Miscellaneous Utilities 754 755(define (current-parse-state #!optional point) 756 (let ((point (if (default-object? point) 757 (current-point) 758 point))) 759 (parse-partial-sexp (or (this-definition-start point) 760 (buffer-start (current-buffer))) 761 point))) 762 763(define (insert-sexp-pair open close sexps #!optional mark) 764 765 (define (insert-space end? mark) 766 (if (and (not (if end? 767 (group-end? mark) 768 (group-start? mark))) 769 (memv (char-syntax (if end? 770 (mark-right-char mark) 771 (mark-left-char mark))) 772 (cons (if end? #\( #\) ) 773 '(#\\ ; escape 774 #\w ; word constituent 775 #\_ ; symbol constituent 776 #\")))) ; string quote 777 (begin (insert-char #\space mark) 778 (mark1+ mark)) 779 mark)) 780 781 (let* ((start (mark-temporary-copy (if (default-object? mark) 782 (current-point) 783 mark))) 784 (before (insert-space #f start))) 785 (insert-char open before) 786 (let ((point (mark1+ before))) 787 (let ((after (forward-sexp point sexps 'ERROR))) 788 (insert-char close after) 789 (insert-space #t (mark1+ after))) 790 (set-current-point! point)))) 791 792(define (insert-newline-preserving-comment #!optional mark) 793 (let ((mark (if (default-object? mark) (current-point) mark))) 794 (cond ((line-margin-comment-region mark) 795 => (lambda (region) 796 (mark-permanent! mark) 797 (let* ((before-semi (region-start region)) 798 (bol (line-start before-semi 0)) 799 (column (region-count-chars 800 (make-region bol before-semi))) 801 (comment (extract-and-delete-string 802 before-semi 803 (region-end region)))) 804 (delete-horizontal-space before-semi) 805 (let ((copy (mark-temporary-copy mark))) 806 (insert-newline mark) 807 (indent-to column 0 copy) 808 (insert-string comment (line-end copy 0)))))) 809 (else 810 (insert-newline mark))))) 811 812;;; This assumes that POINT is before the comment on the line, if there 813;;; is a comment. This assumption may be flawed for general use, but 814;;; it is guaranteed by paredit's use of this procedure. 815 816(define (line-margin-comment-region #!optional point) 817 (let* ((point (if (default-object? point) 818 (current-point) 819 point)) 820 (eol (line-end point 0))) 821 (let loop ((point point) 822 (state (current-parse-state point))) 823 (cond ((char-search-forward #\; point eol) 824 => (lambda (after-semi) 825 (let ((state* (parse-partial-sexp point after-semi 826 #f #f 827 state))) 828 (if (or (mark-left-char-quoted? after-semi) 829 (parse-state-in-string? state*)) 830 (loop after-semi state*) 831 (make-region (mark-1+ after-semi) 832 eol))))) 833 (else #f))))) 834 835(define (start-of-sexp-forward mark) 836 (backward-sexp (forward-sexp mark 1 'ERROR) 1)) 837 838(define (end-of-sexp-backward mark) 839 (forward-sexp (backward-sexp mark 1 'ERROR) 1)) 840 841(define (intervening-text? start end) 842 (mark/= (skip-whitespace-forward start end) 843 end)) 844 845(define (lisp-indent-line-and-sexp) 846 (lisp-indent-line #f) 847 (let ((point (current-point))) 848 (if (cond ((forward-one-sexp point) 849 => (lambda (end) 850 (mark= (line-start (backward-one-sexp end) 0) 851 (line-start point 0)))) 852 (else #f)) 853 (lisp-indent-sexp point)))) 854 855;;; In paredit.el, the ABSOLUTELY? argument determined whether or not 856;;; to override the BLINK-MATCHING-PAREN variable, because in some 857;;; contexts SHOW-PAREN-MODE suffices for the purpose; however, Edwin 858;;; has no such variable or SHOW-PAREN-MODE, but I'd like to make it 859;;; easy to support them later on. 860 861(define (flash-sexp-match #!optional absolutely? point) 862 absolutely? 863 (mark-flash (backward-one-sexp (if (default-object? point) 864 (current-point) 865 point)) 866 'RIGHT)) 867 868(define (char-matching-paren char) 869 ;++ This is a hideous kludge. Why is it necessary? There must be 870 ;++ something built-in that does this. 871 (string-ref (char-syntax->string 872 (get-char-syntax (ref-variable syntax-table) 873 char)) 874 1)) 875 876;;; This assumes that MARK is already in a string. 877 878(define (mark-within-string-escape? mark) 879 (let loop ((flag #f) (mark mark)) 880 (if (char=? (mark-left-char mark) 881 #\\) 882 (loop (not flag) (mark-1+ mark)) 883 flag))) 884 885(define (skip-whitespace-forward #!optional start end) 886 (skip-chars-forward (char-set->string char-set:whitespace) 887 start 888 end)) 889 890(define (char-set->string char-set) 891 (list->string (char-set-members char-set))) 892 893(define (undo-record-point! #!optional buffer) 894 (let ((group (buffer-group (if (default-object? buffer) 895 (current-buffer) 896 buffer)))) 897 (set-group-undo-data! group 898 (cons (mark-index (group-point group)) 899 (group-undo-data group))))) 900 901(define (modify-current-point! modifier) 902 (set-current-point! (modifier (current-point)))) 903 904;;; Edwin Variables: 905;;; outline-pattern: "^\n;;;;+" 906;;; End: 907