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