-
Notifications
You must be signed in to change notification settings - Fork 9
/
poporg.el
824 lines (716 loc) · 30.9 KB
/
poporg.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
;;; poporg.el --- Pop a comment or string to an empty buffer for text editing
;; Copyright © 2014 Joseph Rabinoff.
;; Copyright © 2013 Ubity inc.
;; Author: François Pinard <pinard@iro.umontreal.ca>
;; Joseph Rabinoff <rabinoff@post.harvard.edu>
;; Maintainer: Joseph Rabinoff <rabinoff@post.harvard.edu>
;; Keywords: outlines, tools
;; URL: https://github.com/QBobWatson/poporg
;; This program is free software: you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free Software
;; Foundation, either version 3 of the License, or (at your option) any later
;; version.
;; This program is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;; details.
;; You should have received a copy of the GNU General Public License along with
;; this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; poporg is a small Emacs Lisp project to help editing program strings and
;; comments using Org mode (or any other major mode). This can be useful as it
;; is often more convenient to edit large pieces of text, like Emacs Lisp or
;; Python docstrings, in an org-mode buffer instead of in a comment or a string.
;; See the README.org file located at https://github.com/QBobWatson/poporg for
;; detailed usage information.
;;; Code:
(eval-when-compile
(require 'cl))
;; * Customs
;; ** Group
(defgroup poporg nil
"Edit strings and comments in text buffers."
:prefix "poporg-"
:group 'lisp)
;; ** defcustom's
(defcustom poporg-adjust-fill-column t
"Whether to adjust the fill column in the edit buffer.
If non-nil, in the edit buffer decrement `fill-column' by the prefix length."
:group 'poporg
:type 'boolean)
(defcustom poporg-delete-trailing-whitespace t
"Whether to delete trailing whitespace from the prefix.
If t, when inserting a blank line from the edit buffer back into the source
buffer, remove trailing whitespace from the prefix. This is very useful when
editing docstrings in python, for instance. If equal to the symbol 'all, don't
insert the prefix at all for blank lines."
:group 'poporg
:type '(choice
(const :tag "Do not delete trailing whitespace" nil)
(const :tag "Delete trailing whitespace" t)
(const :tag "Delete the entire prefix" all)))
(defcustom poporg-buffer-name "*poporg: %s*"
"Template for poporg buffer names.
The tag %s is replaced by the original buffer name."
:group 'poporg
:type 'string)
(defcustom poporg-comment-skip-regexp "[[:space:]*]*"
"Ignore these additional characters at the beginning of a commented line.
Characters not matched by this regexp will not be included in the common prefix
for comments. This is matched after `comment-start'. By default this matches
whitespace and the * character; the latter is useful in C-style comments. This
should not match newlines."
:group 'poporg
:type 'regexp)
(defcustom poporg-edit-hook '(org-mode)
"List of hooks to run once a new editing buffer has been filled.
In the absence of any hooks here, the poporg editing buffer is in
`fundamental-mode', so you should probably use this hook to set the major mode.
By default this hook enables `org-mode'."
:group 'poporg
:type 'hook)
(defcustom poporg-edit-exit-hook nil
"List of hooks to run prior to moving back an editing buffer."
:group 'poporg
:type 'hook)
(defvar poporg-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [remap save-buffer] 'poporg-edit-exit)
(define-key map (kbd "C-c C-c") 'poporg-update)
(define-key map (kbd "C-c C-s") 'poporg-update-and-save)
map)
"Keys used in `poporg-mode' buffers.")
;; ** Face
(defface poporg-edited-face
'((((class color) (background light))
(:foreground "gray"))
(((class color) (background dark))
(:foreground "gray")))
"Face for a region while it is being edited."
:group 'poporg)
;; * Internal variables
(defvar poporg-data nil
"List of (BUFFER OVERLAY PREFIX TYPE) lists.
For each edit BUFFER, there is an OVERLAY graying out the edited block comment
or string in the original buffer, and a PREFIX that was removed from all lines
in the edit buffer and which is going to be prepended to these lines before
returning them the original buffer. TYPE is either 'string, 'comment, or
'region.")
(defvar poporg-orig-point nil
"Keeps track of the value of point in the calling buffer.
Dynamically bound variable.")
(defvar poporg-new-point nil
"Keeps track of the value of point in the new buffer.
Dynamically bound variable.")
(defvar poporg-pre-window-configuration nil
"Variable to store the original window configuration.")
;; * Functions
;; ** utility
(defun poporg-chomp (str)
"Chomp leading and trailing whitespace from STR."
(while (string-match
"\\`\n+\\|^\\s-+\\|\\s-+$\\|\n+\\'"
str)
(setq str (replace-match "" t t str)))
str)
(defun poporg-chomp-end (str)
"Chomp trailing whitespace from STR."
(while (string-match "\\s-+$\\|\n+\\'" str)
(setq str (replace-match "" t t str)))
str)
(defun poporg-check-already-edited (beg end)
"Check if there is an already edited region overlapping BEG to END.
If yes, pop the editing buffer for the first one and return t."
(let ((overlays (overlays-in beg end)))
(catch 'found
(while overlays
(let ((entry (overlay-get (pop overlays) 'poporg-overlay)))
(when entry
(pop-to-buffer (car entry))
(throw 'found entry))))
nil)))
(defun poporg-make-buffer ()
"Make a poporg buffer."
(generate-new-buffer (format poporg-buffer-name (buffer-name))))
(defun poporg-fc (arg)
"Like `forward-char' on ARG but won't throw an error."
(condition-case nil (forward-char arg) (error nil)))
(defun poporg-orig-buffer ()
"If this is an edit buffer, find the originating buffer."
(let* ((entry (assq (current-buffer) poporg-data))
(overlay (cadr entry)))
(when overlay (overlay-buffer overlay))))
;; *** skip past comments
(defun poporg-skip-past-comment-start ()
"Skip whitespace, `comment-start', and comment syntax chars."
(skip-syntax-forward " ")
(let ((com-start (if comment-start (poporg-chomp comment-start) "")))
(when (looking-at (regexp-quote com-start))
(goto-char (match-end 0))))
(skip-syntax-forward "<"))
(defun poporg-skip-past-comment-end ()
"Skip whitespace and `comment-end'."
(skip-syntax-forward " ")
(let ((com-end (if comment-end (poporg-chomp comment-end) "")))
(when (looking-at (regexp-quote com-end))
(goto-char (match-end 0)))))
;; *** check whitespace
(defun poporg-whitespace-before-p (pos)
"Return t if there is only whitespace before POS on its line."
(save-excursion
(goto-char pos)
(forward-line 0)
(skip-syntax-forward " ")
(equal pos (if (markerp pos) (point-marker) (point)))))
(defun poporg-whitespace-after-p (pos)
"Return t if there is only whitespace after POS on its line."
(save-excursion
(goto-char pos)
(skip-syntax-forward " ")
(eolp)))
;; ** find and insert
;; *** insert into other buffer
(defun poporg-insert-substring (buf start end)
"Call `insert-buffer-substring-no-properties' on BUF START END.
Keep track of where the point is using `poporg-orig-point'
and `poporg-new-point'."
(let ((starting (point)))
(insert-buffer-substring-no-properties buf start end)
(cond
((>= poporg-orig-point end)
(setq poporg-new-point (point)))
((>= poporg-orig-point start)
(setq poporg-new-point (+ starting (- poporg-orig-point start)))))))
(defun poporg-insert-without-prefix (buf prefix start end)
"Insert lines into BUF after removing PREFIX.
Start at START in current buffer and end at END. On lines that do not start
with prefix, or contain only whitespace after the prefix, just insert a
newline. Respects the value of `poporg-delete-trailing-whitespace'."
(let ((prefix-re (regexp-quote prefix))
(cur-buf (current-buffer)))
(save-excursion
(goto-char start)
(while (< (point) end)
(if (looking-at prefix-re)
(progn
(goto-char (match-end 0))
(if (and poporg-delete-trailing-whitespace
(poporg-whitespace-after-p (point)))
(with-current-buffer buf (insert "\n")) ; uninteresting
;; interesting
(let ((s (point))
(e (save-excursion (forward-line 1) (point))))
(with-current-buffer buf
(poporg-insert-substring cur-buf s e)))))
;; uninteresting
(with-current-buffer buf (insert "\n")))
(forward-line 1)))))
(defun poporg-insert-with-prefix (buf start end prefix &optional no-first)
"Use the contents of BUF to replace the region from START to END.
Prepend PREFIX onto each line. If NO-FIRST is non-nil, do not prepend PREFIX
onto the first line. Delete trailing whitespace from blank lines if
`poporg-delete-trailing-whitespace' is set."
(delete-region start end)
(goto-char start)
(let ((cur-buf (current-buffer))
(prefix-no-ws (poporg-chomp-end prefix)))
(with-current-buffer buf
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(let* ((s (point))
(char-at (char-after s))
e)
(forward-line 1)
(setq e (point))
(with-current-buffer cur-buf
(if no-first
(setq no-first nil)
(if (and poporg-delete-trailing-whitespace
(or (null char-at) (= char-at ?\n)))
;; strip whitespace from prefix for blank lines
(unless (eq poporg-delete-trailing-whitespace 'all)
(insert prefix-no-ws))
(insert prefix)))
(poporg-insert-substring buf s e))))))))
;; *** find string or comment
(defun poporg-find-string-or-comment ()
"Return the start and end positions of the nearest string or comment.
If the point is in a string or comment, this returns the extents of the current
string or comment. If the point is immediately before (resp. after) a string
or comment, returns the extents of the following (resp. preceding) string or
comment. This function uses the current buffer's syntax tables for its
searches.
If a string or comment was found, return a list
(TYPE START END)
where TYPE is either 'string or 'comment and START and END are markers. The
enclosed region includes the delimiters.
If a comment was found, the region between START and END is a number of complete
lines (including trailing newlines) containing only comments. This means that
comments not on their own line are ignored. There may also be blank lines in
this region.
If a string was found, the region from START to END bounds the string with its
delimiters. There will only be whitespace before the start of the string. This
means that a string with non-whitespace before it is ignored.
If no string or comment was found satisfying the above criteria, return nil."
(save-excursion
(let ((ppss (syntax-ppss))
(search-start (point)))
(unless (nth 8 ppss)
;; We're not in a string or comment. Skip past whitespace and search
;; one character at a time until we are. Sometimes stupidest algorithm
;; is the most reliable. First search forward.
(skip-syntax-forward " >")
(catch 'foundit
(dotimes (i 10)
(setq ppss (syntax-ppss))
(when (nth 8 ppss)
(throw 'foundit nil))
(poporg-fc 1))
;; now search backward
(goto-char search-start)
(skip-syntax-backward " >")
(dotimes (i 10)
(setq ppss (syntax-ppss))
(when (nth 8 ppss)
(throw 'foundit nil))
(poporg-fc -1))))
;; done searching
(let ((in-string (nth 3 ppss))
(in-comment (nth 4 ppss))
(start-pos (nth 8 ppss))
start end)
(when start-pos
;; in string or comment
(if in-string
(progn
(setq start (set-marker (make-marker) start-pos))
;; find end of string
(parse-partial-sexp (point) (buffer-size)
nil nil ppss 'syntax-table)
(setq end (point-marker))
(when (poporg-whitespace-before-p start)
(list 'string start end)))
(when in-comment ; should be true at this point
(goto-char start-pos)
;; skip backward over comments and whitespace
(forward-comment (- (buffer-size)))
;; skip forward to beginning of first comment
(skip-syntax-forward " >")
(if (not (poporg-whitespace-before-p (point)))
(forward-line 1) ; it's not on its own line
(forward-line 0))
;; beginning of line of first comment
(setq start (point-marker))
;; skip forward over comments and whitespace
(forward-comment (buffer-size))
;; skip back to end of last comment
(skip-syntax-backward " >")
(save-excursion (forward-line 1)
(setq end (point-marker)))
(when (and (> end start)
(poporg-whitespace-after-p (point)))
(list 'comment start end)))))))))
;; *** insert from comment
(defun poporg-get-comment-lines (buf start end)
"Parse a comment and insert it, with common prefix removed, into BUF.
START and END are positions as returned by `poporg-find-string-or-comment'.
At the beginning of every line, ignore whitespace, `comment-end',
`comment-start', comment syntax characters, and `poporg-comment-skip-regexp', in
that order. This is what is used to calculate the common prefix. If there is
anything left, that line is considered interesting. This skips over
uninteresting lines in the beginning and end. For instance, in the C-style
comment:
/*
* Only this line will be extracted, not the lines above and below.
*/
The prefix will be \" \" or \" * \", depending on whether
`poporg-comment-skip-regexp' matches the star character. If there are no
interesting lines, extract the second comment line, if there is one; otherwise
use the unique comment line.
Return a list (START END PREFIX), where START is the beginning of the first
interesting line, END is the end of the last interesting line (including the
newline), and PREFIX is the common prefix of all interesting lines. START and
END are markers."
(let (start2 end2 line-start line-end prefix)
(save-excursion
(goto-char start)
(forward-line 0)
;; make a list of interesting lines
(while (< (point) end)
(setq line-start (point))
(poporg-skip-past-comment-end)
(poporg-skip-past-comment-start)
(when (looking-at poporg-comment-skip-regexp)
(goto-char (match-end 0)))
(when (not (eolp))
;; this is an interesting line
(setq line-end (save-excursion (forward-line 1) (point)))
;; update prefix
(let ((beg (buffer-substring-no-properties line-start (point))))
(if prefix
(setq prefix (or (fill-common-string-prefix beg prefix) ""))
(setq prefix beg)))
(unless start2 (setq start2 line-start))
(setq end2 line-end))
(forward-line 1)))
(if prefix
;; insert interesting lines into buf
(poporg-insert-without-prefix buf prefix start2 end2)
;; Make a blank buffer; insert over second comment line, or first if there
;; is none. This way one can compose blank comments.
(save-excursion
(goto-char start)
(forward-line 0)
(setq start2 (point))
(forward-line 1)
(if (< (point) end)
;; use the second line
(setq start2 (point))
(goto-char start2))
(skip-syntax-forward "^>")
(setq prefix (buffer-substring-no-properties
start2 (point)))
(forward-line 1)
(setq end2 (point))
(with-current-buffer buf (insert "\n"))))
(list (set-marker (make-marker) start2)
(set-marker (make-marker) end2)
prefix)))
(defun poporg-insert-comment-lines (buf start end prefix overlay)
"Insert the contents of BUF as comments in the current buffer.
Replace the region from START to END and prepend PREFIX onto each line. Append
a trailing newline if necessary. Uses `poporg-insert-with-prefix' to do the
work. Move OVERLAY to the newly-inserted region."
(poporg-insert-with-prefix buf start end prefix)
;; For our purposes, comments always comprise entire lines, so insert a
;; trailing newline if necessary.
(when (with-current-buffer buf
(save-excursion
(goto-char (point-max))
(and (char-before) (not (= (char-before) ?\n)))))
(insert "\n"))
(move-overlay overlay start (point)))
;; *** insert from string
(defun poporg-get-string-lines (buf start end)
"Parse a string and insert it, with common indentation removed, into BUF.
START and END are positions as returned by `poporg-find-string-or-comment'.
This function does not insert the start and end string delimiters. Lines that
are not composed entirely of whitespace count toward determining the
indentation. The indentation of the first line is the indentation before the
opening string delimiter.
This function refuses to edit empty strings, since there is no reliable way to
decide which are the starting and ending delimiters if there is nothing between
them.
Return (START END PREFIX) as in `poporg-get-comment-lines'. The returned values
of START and END agree with the passed arguments. (They are included so that
this function has the same usage as `poporg-get-comment-lines')."
(let* ((beg-last-line (save-excursion
(goto-char end) (forward-line 0) (point)))
(end-last-line (save-excursion
(goto-char end) (skip-syntax-backward "\"|") (point)))
(one-line-p (<= beg-last-line start))
(cur-buf (current-buffer))
prefix line-start start2)
(when (<= end-last-line start)
(user-error "Refusing to edit empty string"))
(save-excursion
(goto-char start)
;; starting prefix is whitespace before opening delimiter
(setq prefix (buffer-substring-no-properties
(save-excursion (forward-line 0) (point)) start))
(forward-line 1)
;; loop over lines with no delimiters
(while (< (point) beg-last-line)
(setq line-start (point))
(skip-syntax-forward " ")
(unless (eolp)
(setq prefix (or (fill-common-string-prefix
(buffer-substring-no-properties
line-start (point))
prefix)
"")))
(forward-line 1))
(unless one-line-p
;; handle last line
(setq line-start (point))
(skip-syntax-forward " ")
(setq prefix (or (fill-common-string-prefix
(buffer-substring-no-properties
line-start (point))
prefix) ""))))
;; insert into buf
(save-excursion
(goto-char start)
(skip-syntax-forward "\"|")
(setq start2 (point))
(if one-line-p
(with-current-buffer buf
(poporg-insert-substring cur-buf start2 end-last-line))
(forward-line 1)
(let ((end2 (point)))
(with-current-buffer buf
(poporg-insert-substring cur-buf start2 end2)))
(poporg-insert-without-prefix buf prefix (point) beg-last-line)
(goto-char beg-last-line)
;; the last line by definition starts with prefix
(forward-char (length prefix))
(setq start2 (point))
(with-current-buffer buf
(poporg-insert-substring cur-buf start2 end-last-line))))
(list (set-marker (make-marker) start)
(set-marker (make-marker) end)
prefix)))
(defun poporg-insert-string-lines (buf start end prefix overlay)
"Insert the contents of BUF into a string in the current buffer.
Replace the string between START and END and prepend PREFIX onto each interior
line. Skip delimiters on both sides. Uses `poporg-insert-with-prefix' to do
the work. Move OVERLAY to the newly-inserted region."
(let ((start-mark (set-marker (make-marker) start))
(end-mark (set-marker (make-marker) end)))
(save-excursion
(goto-char start)
(skip-syntax-forward "\"|")
(setq start (point)))
(save-excursion
(goto-char end)
(skip-syntax-backward "\"|")
(setq end (point)))
(poporg-insert-with-prefix buf start end prefix 'no-first-line)
;; if the buffer is terminated by a newline, need to prepend the prefix before
;; the closing delimiter
(when (with-current-buffer buf
(save-excursion
(goto-char (point-max))
(= (char-before) ?\n)))
(insert prefix))
(move-overlay overlay
(marker-position start-mark)
(marker-position end-mark))))
;; *** insert from region
(defun poporg-get-region-lines (buf start end)
"Insert lines into BUF between START and END with common prefix removed.
This narrows the buffer before doing any parsing. The common prefix is
calculated naively, as the literal common prefixes of all lines in the region
\(after narrowing).
Return (START END PREFIX) as in `poporg-get-comment-lines'. The returned START
and END are the same as the passed arguments."
(save-restriction
(narrow-to-region start end)
(save-excursion
(goto-char (point-min))
(let (line-start prefix)
(while (< (point) (point-max))
(setq line-start (point))
(skip-syntax-forward " ")
(unless (eolp)
;; use the whole line to determine prefix
(let ((line (buffer-substring-no-properties
line-start
(save-excursion (skip-chars-forward "^\n")
(point)))))
(if prefix
(setq prefix (or (fill-common-string-prefix line prefix)
""))
(setq prefix line))))
(forward-line 1))
(unless prefix (setq prefix ""))
(poporg-insert-without-prefix buf prefix (point-min) (point-max))
(list (set-marker (make-marker) start)
(set-marker (make-marker) end)
prefix)))))
(defun poporg-insert-region-lines (buf start end prefix overlay)
"Insert the contents of BUF into the current buffer.
Replace the region between START and END and prepend PREFIX onto each line.
This simply runs `poporg-insert-with-prefix'. Move OVERLAY to the
newly-inserted region."
;; don't have to do anything special
(poporg-insert-with-prefix buf start end prefix)
(move-overlay overlay start (point)))
;; ** make text mode buffer
(defun poporg-edit-thing (start end type)
"Edit the region from START to END in an empty buffer.
Use the function `poporg-get-TYPE-lines' associated to TYPE to extract the
region. Install the protection overlay on the extracted region. If there is an
active editing overlay overlapping the region from START to END, pop to its edit
buffer instead."
(unless (poporg-check-already-edited start end)
(let* ((edit-buffer (poporg-make-buffer))
(f-c fill-column)
(poporg-orig-point (point))
(poporg-new-point 1)
(inserter (intern (concat "poporg-get-" (symbol-name type) "-lines")))
(reg (funcall inserter edit-buffer start end))
(start (nth 0 reg))
(end (nth 1 reg))
(prefix (nth 2 reg))
(overlay (make-overlay start end)))
(setq poporg-pre-window-configuration (current-window-configuration))
;; Dim and protect the original text.
(overlay-put overlay 'face 'poporg-edited-face)
(overlay-put overlay 'intangible t)
(overlay-put overlay 'read-only t)
;; Initialize a popup edit buffer.
(pop-to-buffer edit-buffer)
(goto-char poporg-new-point)
;; Don't allow undoing the initial buffer insertions.
(buffer-disable-undo)
(buffer-enable-undo)
;; Save buffer contents to a temporary file so the undo command knows
;; whether the contents have modified or not. This could potentially have
;; other uses later on.
(let ((buf-name (buffer-name)))
(set-visited-file-name (make-temp-file "poporg-"))
(rename-buffer buf-name t))
(let ((require-final-newline nil)) (save-buffer))
;; This is mainly to hide the `save-buffer' message
(message
(substitute-command-keys
"poporg: type \\<poporg-mode-map>\\[poporg-edit-exit] when done"))
;;(set-buffer-modified-p nil)
;; Save data and possibly activate hooks.
(unless poporg-data
(push 'poporg-kill-buffer-query kill-buffer-query-functions)
(add-hook 'kill-buffer-hook 'poporg-kill-buffer-routine))
(push (list edit-buffer overlay prefix type) poporg-data)
(overlay-put overlay 'poporg-overlay (car poporg-data))
;; All set up for editing.
(with-demoted-errors "Edit hook error: %S" (run-hooks 'poporg-edit-hook))
(poporg-mode +1)
;; Adjust fill column after running the hooks and setting the mode since
;; org-mode sets the fill column.
(when poporg-adjust-fill-column
(setq fill-column (max 0 (- f-c (length prefix))))))))
;; ** buffer kill hook functions
(defun poporg-kill-buffer-query ()
"Warn when killing an edit buffer or a source buffer with active edit buffers."
(let ((entry (assq (current-buffer) poporg-data)))
(if entry
(or (not (buffer-modified-p))
(yes-or-no-p "Really abandon this edit? "))
(let ((data poporg-data)
(value t))
(while data
(let ((buffer (overlay-buffer (cadar data))))
(if (not (eq buffer (current-buffer)))
(setq data (cdr data))
(pop-to-buffer (caar data))
(message "First, either complete or kill this edit.")
(setq data nil
value nil))))
value))))
(defun poporg-kill-buffer-routine ()
"Cleanup an edit buffer whenever killed."
;; Delete the temporary file
(let ((entry (assq (current-buffer) poporg-data)))
(when entry
(let* ((overlay (cadr entry))
(buffer (overlay-buffer overlay)))
(when buffer
(ignore-errors (set-buffer-modified-p nil)
(delete-file (buffer-file-name)))
(delete-overlay overlay)
(setq poporg-data (delq entry poporg-data))
(unless poporg-data
(setq kill-buffer-query-functions
(delq 'poporg-kill-buffer-query kill-buffer-query-functions))
(remove-hook 'kill-buffer-hook 'poporg-kill-buffer-routine))
;; switch back if we're killing the buffer in the selected window
(when (equal (current-buffer) (window-buffer))
(unless (one-window-p) (delete-window))
(switch-to-buffer buffer)))))))
;; * Commands
;;;###autoload
(defun poporg-dwim ()
"Single overall command for poporg (a single keybinding may do it all).
If the current buffer is an edit buffer, run `poporg-edit-exit'.
If the region is active, edit it in an empty buffer. Otherwise, find a nearby
string or comment using `poporg-find-string-or-comment' and edit that in an
empty buffer. If there is an active edit nearby, pop to its other buffer and
edit that instead."
(interactive)
(let ((inhibit-point-motion-hooks t))
(cond
((assq (current-buffer) poporg-data) (poporg-edit-exit))
((use-region-p)
(poporg-edit-thing (region-beginning) (region-end) 'region))
(t
(let ((reg (poporg-find-string-or-comment)))
(cond
((eq (car reg) 'string)
(poporg-edit-thing (nth 1 reg) (nth 2 reg) 'string))
((eq (car reg) 'comment)
(poporg-edit-thing (nth 1 reg) (nth 2 reg) 'comment))
(t
(user-error "Nothing to edit!"))))))))
;;;###autoload
(defun poporg-update (with-save)
"Update the contents of the original buffer.
If prefix argument WITH-SAVE is non-nil, save the original buffer too.
Also update the overlay."
(interactive "P")
(let* ((edit-buffer (current-buffer))
(entry (assq edit-buffer poporg-data))
(overlay (cadr entry))
(buffer (when overlay (overlay-buffer overlay)))
(prefix (caddr entry))
(type (nth 3 entry))
(poporg-orig-point (point))
(inserter (intern (concat "poporg-insert-"
(symbol-name type) "-lines"))))
(unless buffer
(error "Not an edit buffer or original buffer vanished"))
(when (buffer-modified-p)
;; Move everything back in place.
;; Allow the inserter to edit the region.
(overlay-put overlay 'intangible nil)
(overlay-put overlay 'read-only nil)
(let* ((start (overlay-start overlay))
(end (overlay-end overlay)))
(with-current-buffer buffer
;; This updates the overlay
(funcall inserter edit-buffer start end prefix overlay))
;; This is only used to mark the buffer as saved at this tamestamp, so
;; undo knows at what stage the buffer is unmodified
(let ((require-final-newline nil)) (save-buffer))
;; This is manily to hide the `save-buffer' message
(message "poporg: original buffer updated"))
(overlay-put overlay 'intangible t)
(overlay-put overlay 'read-only t))
(with-current-buffer buffer (undo-boundary))
(when with-save (with-current-buffer buffer (save-buffer)))))
;;;###autoload
(defun poporg-update-and-save ()
"Update and save the original buffer; update the region."
(interactive)
(poporg-update t))
;;;###autoload
(defun poporg-edit-exit ()
"Exit the edit buffer, replacing the original region."
(interactive)
(let* ((edit-buffer (current-buffer))
(entry (assq edit-buffer poporg-data))
(overlay (cadr entry))
(buffer (when overlay (overlay-buffer overlay)))
poporg-new-point)
(unless buffer
(error "Not an edit buffer or original buffer vanished"))
(poporg-update nil)
(with-demoted-errors "Edit hook error: %S"
(run-hooks 'poporg-edit-exit-hook))
;; Killing the buffer triggers a cleanup through the kill hook.
(kill-buffer edit-buffer)
(set-window-configuration poporg-pre-window-configuration)
(with-current-buffer buffer
(let ((inhibit-point-motion-hooks t))
(when poporg-new-point ; unset if unmodified or aborted
(goto-char poporg-new-point))))))
;; ** mode
(define-minor-mode poporg-mode
"Install keybindings for a poporg edit buffer."
nil " pop" poporg-mode-map)
(provide 'poporg)
;; Local Variables:
;; coding: utf-8
;; End:
;;; poporg.el ends here