2021-04-26 07:53:20 -04:00
|
|
|
|
#| -*-Scheme-*-
|
|
|
|
|
|
|
|
|
|
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
|
|
|
|
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
|
|
|
|
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
|
|
|
|
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
|
|
|
|
|
|
|
|
|
This file is part of MIT/GNU Scheme.
|
|
|
|
|
|
|
|
|
|
MIT/GNU Scheme 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 2 of the License, or (at
|
|
|
|
|
your option) any later version.
|
|
|
|
|
|
|
|
|
|
MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
|
|
|
|
|
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
|
|
|
|
USA.
|
|
|
|
|
|
|
|
|
|
|#
|
|
|
|
|
|
|
|
|
|
;;;; Text Fill Commands
|
|
|
|
|
|
2021-04-26 07:57:47 -04:00
|
|
|
|
|
2021-04-26 07:53:20 -04:00
|
|
|
|
|
|
|
|
|
(define-variable-per-buffer fill-column
|
|
|
|
|
"Column beyond which automatic line-wrapping should happen.
|
|
|
|
|
Automatically becomes local when set in any fashion."
|
|
|
|
|
70
|
|
|
|
|
exact-nonnegative-integer?)
|
|
|
|
|
|
|
|
|
|
(define-variable-per-buffer fill-prefix
|
|
|
|
|
"String for filling to insert at front of new line, or #f for none.
|
|
|
|
|
Setting this variable automatically makes it local to the current buffer."
|
|
|
|
|
#f
|
|
|
|
|
string-or-false?)
|
|
|
|
|
|
|
|
|
|
(define-variable-per-buffer left-margin
|
|
|
|
|
"Column for the default indent-line-function to indent to.
|
|
|
|
|
Linefeed indents to this column in Fundamental mode.
|
|
|
|
|
Automatically becomes local when set in any fashion."
|
|
|
|
|
0
|
|
|
|
|
exact-nonnegative-integer?)
|
|
|
|
|
|
|
|
|
|
(define-variable adaptive-fill-mode
|
|
|
|
|
"True means determine a paragraph's fill prefix from its text."
|
|
|
|
|
#t
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable adaptive-fill-regexp
|
|
|
|
|
"Regexp to match text at start of line that constitutes indentation.
|
|
|
|
|
If Adaptive Fill mode is enabled, a prefix matching this pattern
|
|
|
|
|
on the first and second lines of a paragraph is used as the
|
|
|
|
|
standard indentation for the whole paragraph.
|
|
|
|
|
|
|
|
|
|
If the paragraph has just one line, the indentation is taken from that
|
|
|
|
|
line, but in that case `adaptive-fill-first-line-regexp' also plays
|
|
|
|
|
a role."
|
|
|
|
|
"[ \t]*\\([-|#;>*]+ *\\|(?[0-9]+[.)] *\\)*"
|
|
|
|
|
string?)
|
|
|
|
|
|
|
|
|
|
(define-variable adaptive-fill-first-line-regexp
|
|
|
|
|
"Regexp specifying whether to set fill prefix from a one-line paragraph.
|
|
|
|
|
When a paragraph has just one line, then after `adaptive-fill-regexp'
|
|
|
|
|
finds the prefix at the beginning of the line, if it doesn't
|
|
|
|
|
match this regexp, it is replaced with whitespace.
|
|
|
|
|
|
|
|
|
|
By default, this regexp matches sequences of just spaces and tabs.
|
|
|
|
|
|
|
|
|
|
However, we never use a prefix from a one-line paragraph
|
|
|
|
|
if it would act as a paragraph-starter on the second line."
|
|
|
|
|
"\\`[ \t]*\\'"
|
|
|
|
|
string?)
|
|
|
|
|
|
|
|
|
|
(define-variable adaptive-fill-procedure
|
|
|
|
|
"Procedure to call to choose a fill prefix for a paragraph.
|
|
|
|
|
This procedure is used when `adaptive-fill-regexp' does not match."
|
|
|
|
|
#f
|
|
|
|
|
(lambda (object) (or (not object) (procedure? object))))
|
|
|
|
|
|
|
|
|
|
(define-command set-fill-column
|
|
|
|
|
"Set fill-column to current column, or to argument if given.
|
|
|
|
|
fill-column's value is separate for each buffer."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (argument)
|
|
|
|
|
(let ((column
|
|
|
|
|
(or (command-argument-value argument)
|
|
|
|
|
(current-column))))
|
|
|
|
|
(set-variable! fill-column column)
|
|
|
|
|
(message "fill-column set to " column))))
|
|
|
|
|
|
|
|
|
|
(define-command set-fill-prefix
|
|
|
|
|
"Set the fill-prefix to the current line up to point.
|
|
|
|
|
Filling expects lines to start with the fill prefix
|
|
|
|
|
and reinserts the fill prefix in each resulting line."
|
|
|
|
|
"d"
|
|
|
|
|
(lambda (point)
|
|
|
|
|
(let ((string (extract-string (line-start point 0) point)))
|
|
|
|
|
(if (string-null? string)
|
|
|
|
|
(begin
|
|
|
|
|
(set-variable! fill-prefix #f)
|
|
|
|
|
(message "fill-prefix cancelled"))
|
|
|
|
|
(begin
|
|
|
|
|
(set-variable! fill-prefix string)
|
|
|
|
|
(message "fill-prefix: \"" string "\""))))))
|
|
|
|
|
|
|
|
|
|
(define-command fill-paragraph
|
|
|
|
|
"Fill paragraph at or after point.
|
|
|
|
|
Prefix arg means justify as well."
|
|
|
|
|
"d\nP"
|
|
|
|
|
(lambda (point justify?)
|
|
|
|
|
(let ((region (paragraph-text-region point)))
|
|
|
|
|
(if (not region)
|
|
|
|
|
(editor-error))
|
|
|
|
|
((ref-command fill-region-as-paragraph) region justify?))))
|
|
|
|
|
|
|
|
|
|
(define-command fill-region-as-paragraph
|
|
|
|
|
"Fill region as one paragraph: break lines to fit fill-column.
|
|
|
|
|
Prefix arg means justify too."
|
|
|
|
|
"r\nP"
|
|
|
|
|
(lambda (region justify?)
|
|
|
|
|
(let ((start (region-start region)))
|
|
|
|
|
(fill-region-as-paragraph
|
|
|
|
|
start
|
|
|
|
|
(region-end region)
|
|
|
|
|
(ref-variable fill-prefix start)
|
|
|
|
|
(ref-variable fill-column start)
|
|
|
|
|
justify?))))
|
|
|
|
|
|
|
|
|
|
(define-command fill-individual-paragraphs
|
|
|
|
|
"Fill each paragraph in region according to its individual fill prefix."
|
|
|
|
|
"r\nP"
|
|
|
|
|
(lambda (region justify?)
|
|
|
|
|
(let ((start (region-start region)))
|
|
|
|
|
(fill-individual-paragraphs start
|
|
|
|
|
(region-end region)
|
|
|
|
|
(ref-variable fill-column start)
|
|
|
|
|
justify?
|
|
|
|
|
#f))))
|
|
|
|
|
|
|
|
|
|
(define-command fill-region
|
|
|
|
|
"Fill each of the paragraphs in the region.
|
|
|
|
|
Prefix arg means justify as well."
|
|
|
|
|
"r\nP"
|
|
|
|
|
(lambda (region justify?)
|
|
|
|
|
(let ((start (region-start region)))
|
|
|
|
|
(fill-region start
|
|
|
|
|
(region-end region)
|
|
|
|
|
(ref-variable fill-prefix start)
|
|
|
|
|
(ref-variable fill-column start)
|
|
|
|
|
justify?))))
|
|
|
|
|
|
|
|
|
|
(define-command justify-current-line
|
|
|
|
|
"Add spaces to line point is in, so it ends at fill-column."
|
|
|
|
|
"d"
|
|
|
|
|
(lambda (point)
|
|
|
|
|
(justify-line point
|
|
|
|
|
(ref-variable fill-prefix point)
|
|
|
|
|
(ref-variable fill-column point))))
|
|
|
|
|
|
|
|
|
|
(define-command center-line
|
|
|
|
|
"Center the line point is on, within the width specified by `fill-column'.
|
|
|
|
|
This means adjusting the indentation to match
|
|
|
|
|
the distance between the end of the text and `fill-column'."
|
|
|
|
|
"d"
|
|
|
|
|
(lambda (mark) (center-line mark)))
|
|
|
|
|
|
|
|
|
|
(define (center-line mark)
|
|
|
|
|
(let ((mark (mark-permanent! mark)))
|
|
|
|
|
(delete-horizontal-space (line-start mark 0))
|
|
|
|
|
(delete-horizontal-space (line-end mark 0))
|
|
|
|
|
(let ((d
|
|
|
|
|
(- (- (ref-variable fill-column mark)
|
|
|
|
|
(ref-variable left-margin mark))
|
|
|
|
|
(mark-column (line-end mark 0)))))
|
|
|
|
|
(if (positive? d)
|
|
|
|
|
(insert-horizontal-space (+ (ref-variable left-margin mark)
|
|
|
|
|
(quotient d 2))
|
|
|
|
|
(line-start mark 0))))))
|
|
|
|
|
|
|
|
|
|
(define (fill-region-as-paragraph start end fill-prefix fill-column justify?)
|
|
|
|
|
(let ((start (mark-right-inserting-copy (skip-chars-forward "\n" start end)))
|
|
|
|
|
(end (mark-left-inserting-copy (skip-chars-backward "\n" end start))))
|
|
|
|
|
(let ((fill-prefix
|
|
|
|
|
(or fill-prefix
|
|
|
|
|
(and (ref-variable adaptive-fill-mode start)
|
|
|
|
|
(fill-context-prefix start end))))
|
|
|
|
|
(point (mark-left-inserting-copy start)))
|
|
|
|
|
;; Delete the fill prefix from every line except the first.
|
|
|
|
|
(if fill-prefix
|
|
|
|
|
(begin
|
|
|
|
|
(if (>= (string-length fill-prefix) fill-column)
|
|
|
|
|
(editor-error "fill-prefix too long for specified width"))
|
|
|
|
|
(let ((m (match-forward fill-prefix start end #f)))
|
|
|
|
|
(if m
|
|
|
|
|
(begin
|
|
|
|
|
(move-mark-to! point m)
|
|
|
|
|
(move-mark-to! start m))))
|
|
|
|
|
(let loop ()
|
|
|
|
|
(let ((m (char-search-forward #\newline point end)))
|
|
|
|
|
(if m
|
|
|
|
|
(begin
|
|
|
|
|
(move-mark-to! point m)
|
|
|
|
|
(let ((m (match-forward fill-prefix point end #f)))
|
|
|
|
|
(if m
|
|
|
|
|
(delete-string point m)))
|
|
|
|
|
(loop)))))
|
|
|
|
|
(move-mark-to! point start)))
|
|
|
|
|
;; Make sure sentences ending at end of line get an extra space.
|
|
|
|
|
(let loop ()
|
|
|
|
|
(let ((m (re-search-forward "[.?!][])\"']*$" point end #f)))
|
|
|
|
|
(if m
|
|
|
|
|
(begin
|
|
|
|
|
(move-mark-to! point m)
|
|
|
|
|
(insert-char #\space point)
|
|
|
|
|
(loop)))))
|
|
|
|
|
;; Change all newlines to spaces.
|
|
|
|
|
(move-mark-to! point start)
|
|
|
|
|
(let loop ()
|
|
|
|
|
(let ((m (char-search-forward #\newline point end)))
|
|
|
|
|
(if m
|
|
|
|
|
(begin
|
|
|
|
|
(move-mark-to! point m)
|
|
|
|
|
(delete-left-char point)
|
|
|
|
|
(insert-char #\space point)
|
|
|
|
|
(loop)))))
|
|
|
|
|
;; Flush excess spaces, except in the paragraph indentation.
|
|
|
|
|
(move-mark-to! point (skip-chars-forward " \t" start end))
|
|
|
|
|
(let loop ()
|
|
|
|
|
(if (re-search-forward " *" point end #f)
|
|
|
|
|
(begin
|
|
|
|
|
(move-mark-to! point (delete-match))
|
|
|
|
|
(insert-string (if (fill:sentence-end? point start) " " " ")
|
|
|
|
|
point)
|
|
|
|
|
(loop))))
|
|
|
|
|
(delete-string (horizontal-space-start end) end)
|
|
|
|
|
(insert-string " " end)
|
|
|
|
|
(move-mark-to! point start)
|
|
|
|
|
(let loop ()
|
|
|
|
|
(let ((target (move-to-column point fill-column)))
|
|
|
|
|
(if (mark>= target (horizontal-space-start end))
|
|
|
|
|
(delete-horizontal-space end)
|
|
|
|
|
(begin
|
|
|
|
|
(move-mark-to!
|
|
|
|
|
point
|
|
|
|
|
(if (char=? #\space (extract-right-char target))
|
|
|
|
|
target
|
|
|
|
|
(let ((m (skip-chars-backward "^ \n" target point)))
|
|
|
|
|
(if (mark> m point)
|
|
|
|
|
m
|
|
|
|
|
(skip-chars-forward "^ \n" target end)))))
|
|
|
|
|
(if (mark< point end)
|
|
|
|
|
(begin
|
|
|
|
|
(delete-horizontal-space point)
|
|
|
|
|
(if (mark< point end) (insert-newline point))
|
|
|
|
|
(if justify?
|
|
|
|
|
(fill:call-with-line-marks
|
|
|
|
|
(if (mark< point end) (mark-1+ point) point)
|
|
|
|
|
fill-prefix
|
|
|
|
|
(lambda (start end)
|
|
|
|
|
(fill:justify-line start end fill-column))))
|
|
|
|
|
(if fill-prefix (insert-string fill-prefix point))))
|
|
|
|
|
(if (mark< point end)
|
|
|
|
|
(loop))))))
|
|
|
|
|
(mark-temporary! point)
|
|
|
|
|
(mark-temporary! end)
|
|
|
|
|
(mark-temporary! start))))
|
|
|
|
|
|
|
|
|
|
(define (fill-region start end fill-prefix fill-column justify?)
|
|
|
|
|
(let ((start (mark-right-inserting-copy start))
|
|
|
|
|
(end (mark-left-inserting-copy end))
|
|
|
|
|
(point (mark-left-inserting-copy start))
|
|
|
|
|
(pend (mark-left-inserting-copy start)))
|
|
|
|
|
(let loop ()
|
|
|
|
|
(if (mark< point end)
|
|
|
|
|
(begin
|
|
|
|
|
(move-mark-to! pend
|
|
|
|
|
(or (forward-one-paragraph point end fill-prefix)
|
|
|
|
|
end))
|
|
|
|
|
(if (mark>= (or (backward-one-paragraph pend start fill-prefix)
|
|
|
|
|
start)
|
|
|
|
|
point)
|
|
|
|
|
(fill-region-as-paragraph point
|
|
|
|
|
pend
|
|
|
|
|
fill-prefix
|
|
|
|
|
fill-column
|
|
|
|
|
justify?))
|
|
|
|
|
(move-mark-to! point pend)
|
|
|
|
|
(loop))))
|
|
|
|
|
(mark-temporary! pend)
|
|
|
|
|
(mark-temporary! point)
|
|
|
|
|
(mark-temporary! end)
|
|
|
|
|
(mark-temporary! start)))
|
|
|
|
|
|
|
|
|
|
(define (fill-individual-paragraphs start end fill-column justify? mail?)
|
|
|
|
|
(operate-on-individual-paragraphs start end mail?
|
|
|
|
|
(lambda (p-start p-end fill-prefix)
|
|
|
|
|
(fill-region-as-paragraph p-start p-end fill-prefix
|
|
|
|
|
fill-column justify?))))
|
|
|
|
|
|
|
|
|
|
(define (operate-on-individual-paragraphs start end mail? operator)
|
|
|
|
|
(let ((point (mark-left-inserting-copy start))
|
|
|
|
|
(pend (mark-left-inserting-copy start))
|
|
|
|
|
(end (mark-left-inserting-copy end))
|
|
|
|
|
(paragraph-separate (ref-variable paragraph-separate start))
|
|
|
|
|
(compute-prefix
|
|
|
|
|
(lambda (point)
|
|
|
|
|
(let ((ls (line-start point 0)))
|
|
|
|
|
(or (and (ref-variable adaptive-fill-mode point)
|
|
|
|
|
(fill-context-prefix ls (line-end point 0) ""))
|
|
|
|
|
(extract-string ls point))))))
|
|
|
|
|
(if (and mail? (re-search-forward "^[ \t]*[^ \t\n]*:" point end #f))
|
|
|
|
|
(move-mark-to! point (or (search-forward "\n\n" point end #f) end)))
|
|
|
|
|
(let loop ()
|
|
|
|
|
(move-mark-to!
|
|
|
|
|
point
|
|
|
|
|
(let skip-separators ((mark point))
|
|
|
|
|
(cond ((mark>= mark end) end)
|
|
|
|
|
((let* ((ls (skip-chars-forward " \t" mark end))
|
|
|
|
|
(fill-prefix
|
|
|
|
|
(and (ref-variable adaptive-fill-mode ls)
|
|
|
|
|
(fill-context-prefix ls (line-end ls 0) ""))))
|
|
|
|
|
(if fill-prefix
|
|
|
|
|
(let ((fp (match-forward fill-prefix ls end #f)))
|
|
|
|
|
(or (not fp)
|
|
|
|
|
(re-match-forward paragraph-separate fp end #f)))
|
|
|
|
|
(re-match-forward paragraph-separate ls end #f)))
|
|
|
|
|
(skip-separators (line-start mark 1 'LIMIT)))
|
|
|
|
|
(else mark))))
|
|
|
|
|
(move-mark-to! point (skip-chars-forward " \t" point end))
|
|
|
|
|
(if (mark< point end)
|
|
|
|
|
(let ((fill-prefix (compute-prefix point)))
|
|
|
|
|
(let find-end ((le (line-end point 0 'ERROR)))
|
|
|
|
|
(let ((ls
|
|
|
|
|
(and (mark< le end)
|
|
|
|
|
(skip-chars-forward " \t"
|
|
|
|
|
(line-start le 1 'ERROR)
|
|
|
|
|
end))))
|
|
|
|
|
(if (and ls
|
|
|
|
|
(mark< ls end)
|
|
|
|
|
(let ((m (match-forward fill-prefix ls)))
|
|
|
|
|
(and m
|
|
|
|
|
(not (paragraph-start? m end))))
|
|
|
|
|
(string=? (compute-prefix ls) fill-prefix))
|
|
|
|
|
(find-end (line-end ls 0 'ERROR))
|
|
|
|
|
(move-mark-to! pend le))))
|
|
|
|
|
(operator point pend fill-prefix)
|
|
|
|
|
(let ((ls (line-start pend 1 #f)))
|
|
|
|
|
(if (and ls (mark< ls end))
|
|
|
|
|
(begin
|
|
|
|
|
(move-mark-to! point ls)
|
|
|
|
|
(loop)))))))
|
|
|
|
|
(mark-temporary! pend)
|
|
|
|
|
(mark-temporary! point)
|
|
|
|
|
(mark-temporary! end)
|
|
|
|
|
(mark-temporary! start)))
|
|
|
|
|
|
|
|
|
|
(define (justify-line mark fill-prefix fill-column)
|
|
|
|
|
(fill:call-with-line-marks mark fill-prefix
|
|
|
|
|
(lambda (start end)
|
|
|
|
|
(let ((point (mark-left-inserting-copy start)))
|
|
|
|
|
(let loop ()
|
|
|
|
|
(if (re-search-forward " *" point end #f)
|
|
|
|
|
(begin
|
|
|
|
|
(move-mark-to! point (delete-match))
|
|
|
|
|
(insert-string (if (fill:sentence-end? point start) " " " ")
|
|
|
|
|
point)
|
|
|
|
|
(loop))))
|
|
|
|
|
(mark-temporary! point))
|
|
|
|
|
(fill:justify-line start end fill-column))))
|
|
|
|
|
|
|
|
|
|
(define (fill:call-with-line-marks mark fill-prefix procedure)
|
|
|
|
|
(let ((end (mark-left-inserting-copy (line-end mark 0))))
|
|
|
|
|
(let ((start
|
|
|
|
|
(mark-right-inserting-copy
|
|
|
|
|
(skip-chars-forward
|
|
|
|
|
" \t"
|
|
|
|
|
(let ((start (line-start end 0)))
|
|
|
|
|
(or (and fill-prefix
|
|
|
|
|
(match-forward fill-prefix start end #f))
|
|
|
|
|
start))
|
|
|
|
|
end))))
|
|
|
|
|
(procedure start end)
|
|
|
|
|
(mark-temporary! start)
|
|
|
|
|
(mark-temporary! end))))
|
|
|
|
|
|
|
|
|
|
(define (fill:justify-line start end fill-column)
|
|
|
|
|
(let ((point (mark-right-inserting-copy end)))
|
|
|
|
|
(do ((ncols (- fill-column (mark-column end)) (- ncols 1)))
|
|
|
|
|
((<= ncols 0))
|
|
|
|
|
(do ((i (+ 3 (random 3)) (- i 1)))
|
|
|
|
|
((= i 0))
|
|
|
|
|
(move-mark-to!
|
|
|
|
|
point
|
|
|
|
|
(skip-chars-backward " "
|
|
|
|
|
(or (char-search-backward #\space point start)
|
|
|
|
|
(char-search-backward #\space end start)
|
|
|
|
|
start)
|
|
|
|
|
start)))
|
|
|
|
|
(insert-char #\space point))
|
|
|
|
|
(mark-temporary! point)))
|
|
|
|
|
|
|
|
|
|
(define (fill:sentence-end? point start)
|
|
|
|
|
(let ((m (skip-chars-backward "])\"'" point start)))
|
|
|
|
|
(and (not (group-start? m))
|
|
|
|
|
(memv (extract-left-char m) '(#\. #\? #\!)))))
|
|
|
|
|
|
|
|
|
|
(define (fill-context-prefix start end #!optional first-line-regexp)
|
|
|
|
|
;; Assume that START is at the start of the first line, and END is at the
|
|
|
|
|
;; end of the last line.
|
|
|
|
|
(let ((first-line-regexp
|
|
|
|
|
(if (or (default-object? first-line-regexp) (not first-line-regexp))
|
|
|
|
|
(ref-variable adaptive-fill-first-line-regexp start)
|
|
|
|
|
first-line-regexp))
|
|
|
|
|
(test-line
|
|
|
|
|
(lambda (start)
|
|
|
|
|
(cond ((re-match-forward (ref-variable paragraph-start start) start)
|
|
|
|
|
#f)
|
|
|
|
|
((and (ref-variable adaptive-fill-regexp start)
|
|
|
|
|
(re-match-forward (ref-variable adaptive-fill-regexp
|
|
|
|
|
start)
|
|
|
|
|
start))
|
|
|
|
|
(extract-string start (re-match-end 0)))
|
|
|
|
|
((ref-variable adaptive-fill-procedure start)
|
|
|
|
|
((ref-variable adaptive-fill-procedure start) start end))
|
|
|
|
|
(else #f)))))
|
|
|
|
|
(let ((first-line-prefix (test-line start))
|
|
|
|
|
(multi-line? (mark< (line-end start 0) end)))
|
|
|
|
|
(and first-line-prefix
|
|
|
|
|
(if multi-line?
|
|
|
|
|
;; If we get a fill prefix from the second line, make sure it
|
|
|
|
|
;; or something compatible is on the first line too.
|
|
|
|
|
(let ((second-line-prefix (test-line (line-start start 1))))
|
|
|
|
|
(cond ((not second-line-prefix)
|
|
|
|
|
#f)
|
|
|
|
|
((re-string-match
|
|
|
|
|
(string-append (re-quote-string second-line-prefix)
|
|
|
|
|
"\\(\\'\\|[ \t]\\)")
|
|
|
|
|
first-line-prefix)
|
|
|
|
|
;; If the first line has the second line prefix too,
|
|
|
|
|
;; use it.
|
|
|
|
|
second-line-prefix)
|
|
|
|
|
((re-string-match "[ \t]+\\'" second-line-prefix)
|
|
|
|
|
;; If the second line prefix is whitespace, use it.
|
|
|
|
|
second-line-prefix)
|
|
|
|
|
((re-string-match
|
|
|
|
|
(string-append (re-quote-string first-line-prefix)
|
|
|
|
|
"[ \t]*\\'")
|
|
|
|
|
second-line-prefix)
|
|
|
|
|
;; If the second line has the first line prefix, plus
|
|
|
|
|
;; whitespace, use the part that the first line shares.
|
|
|
|
|
first-line-prefix)
|
|
|
|
|
(else #f)))
|
|
|
|
|
;; If we get a fill prefix from a one-line paragraph, maybe
|
|
|
|
|
;; change it to whitespace, and check that it isn't a paragraph
|
|
|
|
|
;; starter.
|
|
|
|
|
(let ((result
|
|
|
|
|
;; If first-line-prefix comes from the first line, see
|
|
|
|
|
;; if it seems reasonable to use for all lines. If not,
|
|
|
|
|
;; replace it with whitespace.
|
|
|
|
|
(if (or (and first-line-regexp
|
|
|
|
|
(re-string-search-forward
|
|
|
|
|
first-line-regexp
|
|
|
|
|
first-line-prefix))
|
|
|
|
|
(fill-prefix-is-comment? first-line-prefix
|
|
|
|
|
start))
|
|
|
|
|
first-line-prefix
|
|
|
|
|
(make-string (string-length first-line-prefix)
|
|
|
|
|
#\space))))
|
|
|
|
|
;; But either way, reject it if it indicates the start of a
|
|
|
|
|
;; paragraph when text follows it.
|
|
|
|
|
(and (not (re-string-match (ref-variable paragraph-start
|
|
|
|
|
start)
|
|
|
|
|
(string-append result "a")))
|
|
|
|
|
result)))))))
|
|
|
|
|
|
|
|
|
|
(define (fill-prefix-is-comment? prefix mark)
|
|
|
|
|
(let ((locator (ref-variable comment-locator-hook mark)))
|
|
|
|
|
(and locator
|
|
|
|
|
(call-with-temporary-buffer " adaptive fill"
|
|
|
|
|
(lambda (buffer)
|
|
|
|
|
(insert-string prefix (buffer-start buffer))
|
|
|
|
|
(let ((com (locator (buffer-start buffer))))
|
|
|
|
|
(and com
|
|
|
|
|
(within-indentation? (car com))
|
|
|
|
|
(group-end? (cdr com)))))))))
|
|
|
|
|
|
|
|
|
|
;;;; Auto Fill
|
|
|
|
|
|
|
|
|
|
(define-command auto-fill-mode
|
|
|
|
|
"Toggle auto-fill mode.
|
|
|
|
|
With argument, turn auto-fill mode on iff argument is positive."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (argument)
|
|
|
|
|
(let ((mode (ref-mode-object auto-fill)))
|
|
|
|
|
(if (if argument
|
|
|
|
|
(positive? (command-argument-value argument))
|
|
|
|
|
(not (current-minor-mode? mode)))
|
|
|
|
|
(enable-current-minor-mode! mode)
|
|
|
|
|
(disable-current-minor-mode! mode)))))
|
|
|
|
|
|
|
|
|
|
(define-minor-mode auto-fill "Fill"
|
|
|
|
|
"Minor mode in which lines are automatically wrapped when long enough.")
|
|
|
|
|
|
|
|
|
|
(define (auto-fill-break point)
|
|
|
|
|
(and (auto-fill-break? point)
|
|
|
|
|
(let ((prefix
|
|
|
|
|
(or (and (not
|
|
|
|
|
(ref-variable paragraph-ignore-fill-prefix point))
|
|
|
|
|
(ref-variable fill-prefix point))
|
|
|
|
|
(and (ref-variable adaptive-fill-mode point)
|
|
|
|
|
(fill-context-prefix (or (paragraph-text-start point)
|
|
|
|
|
(line-start point 0))
|
|
|
|
|
(or (paragraph-text-end point)
|
|
|
|
|
(line-end point 0)))))))
|
|
|
|
|
(and (re-search-backward "[^ \t][ \t]+"
|
|
|
|
|
(move-to-column
|
|
|
|
|
point
|
|
|
|
|
(+ (ref-variable fill-column) 1))
|
|
|
|
|
(line-start point 0))
|
|
|
|
|
(let ((break (re-match-end 0)))
|
|
|
|
|
(and (let ((pe
|
|
|
|
|
(and prefix
|
|
|
|
|
(mark+ (line-start point 0)
|
|
|
|
|
(string-length prefix)
|
|
|
|
|
#f))))
|
|
|
|
|
(or (not pe)
|
|
|
|
|
(mark> break pe)))
|
|
|
|
|
(begin
|
|
|
|
|
(indent-new-comment-line break prefix)
|
|
|
|
|
#t)))))))
|
|
|
|
|
|
|
|
|
|
(define (auto-fill-break? point)
|
|
|
|
|
(> (mark-column point) (ref-variable fill-column)))
|
|
|
|
|
|
|
|
|
|
;;;; Wrap lines
|
|
|
|
|
|
|
|
|
|
(define (wrap-individual-paragraphs start end fill-column mail?)
|
|
|
|
|
(operate-on-individual-paragraphs start end mail?
|
|
|
|
|
(lambda (p-start p-end fill-prefix)
|
|
|
|
|
(wrap-region-as-paragraph p-start p-end fill-prefix fill-column))))
|
|
|
|
|
|
|
|
|
|
(define (wrap-region-as-paragraph p-start p-end fill-prefix fill-column)
|
|
|
|
|
(let ((m (mark-left-inserting-copy (line-end p-start 0)))
|
|
|
|
|
(group (mark-group p-start))
|
|
|
|
|
(fp-length (and fill-prefix (string-length fill-prefix)))
|
|
|
|
|
(target-column (fix:+ fill-column 1)))
|
|
|
|
|
(let ((tab-width (group-tab-width group))
|
|
|
|
|
(image-strings (group-char-image-strings group)))
|
|
|
|
|
(let loop ()
|
|
|
|
|
(delete-horizontal-space m)
|
|
|
|
|
(let inner ()
|
|
|
|
|
(let* ((index (mark-index m))
|
|
|
|
|
(ls-index (line-start-index group index))
|
|
|
|
|
(v
|
|
|
|
|
(group-column->index group
|
|
|
|
|
ls-index
|
|
|
|
|
index
|
|
|
|
|
0
|
|
|
|
|
target-column
|
|
|
|
|
tab-width
|
|
|
|
|
image-strings)))
|
|
|
|
|
(if (and (fix:>= (vector-ref v 1) target-column)
|
|
|
|
|
(fix:<= (vector-ref v 0) index)
|
|
|
|
|
(re-search-backward "[^ \t][ \t]+"
|
|
|
|
|
(make-mark group (vector-ref v 0))
|
|
|
|
|
(make-mark group ls-index)))
|
|
|
|
|
(let ((break (re-match-end 0)))
|
|
|
|
|
(if (or (not fill-prefix)
|
|
|
|
|
(fix:> (fix:- (mark-index break) ls-index)
|
|
|
|
|
fp-length))
|
|
|
|
|
(begin
|
|
|
|
|
(indent-new-comment-line break fill-prefix)
|
|
|
|
|
(inner)))))))
|
|
|
|
|
(if (mark< m p-end)
|
|
|
|
|
(begin
|
|
|
|
|
(move-mark-to! m (line-end m 1 'ERROR))
|
|
|
|
|
(loop)))))
|
2021-04-26 07:57:47 -04:00
|
|
|
|
(mark-temporary! m)))
|