249 lines
7.9 KiB
Scheme
249 lines
7.9 KiB
Scheme
#| -*-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.
|
||
|
||
|#
|
||
|
||
;;;; Dynamic Abbrev
|
||
|
||
|
||
|
||
(define-variable dabbrevs-backward-only
|
||
"If true, dabbrevs-expand only looks backwards."
|
||
false
|
||
boolean?)
|
||
|
||
(define-variable-per-buffer dabbrevs-limit
|
||
"Limits region searched by dabbrevs-expand to that many chars away (local)."
|
||
false
|
||
(lambda (object)
|
||
(or (not object)
|
||
(exact-integer? object))))
|
||
|
||
(define-variable-per-buffer last-dabbrev-table
|
||
"Table of expansions seen so far (local)."
|
||
'())
|
||
|
||
(define-variable-per-buffer last-dabbrevs-abbreviation
|
||
"Last string we tried to expand (local)."
|
||
""
|
||
string?)
|
||
|
||
(define-variable-per-buffer last-dabbrevs-direction
|
||
"Direction of last dabbrevs search (local)."
|
||
0
|
||
exact-integer?)
|
||
|
||
(define-variable-per-buffer last-dabbrevs-abbrev-location
|
||
"Location last abbreviation began (local)."
|
||
false)
|
||
|
||
(define-variable-per-buffer last-dabbrevs-expansion
|
||
"Last expansion of an abbreviation (local)."
|
||
false)
|
||
|
||
(define-variable-per-buffer last-dabbrevs-expansion-location
|
||
"Location the last expansion was found (local)."
|
||
false)
|
||
|
||
(define dabbrev-tag "Dabbrev")
|
||
|
||
(define-command dabbrev-expand
|
||
"Expand previous word \"dynamically\".
|
||
Expands to the most recent, preceding word for which this is a prefix.
|
||
If no suitable preceding word is found, words following point are considered.
|
||
|
||
A positive prefix argument, N, says to take the Nth backward DISTINCT
|
||
possibility. A negative argument says search forward. The variable
|
||
dabbrev-backward-only may be used to limit the direction of search to
|
||
backward if set non-nil.
|
||
|
||
If the cursor has not moved from the end of the previous expansion and
|
||
no argument is given, replace the previously-made expansion
|
||
with the next possible expansion not yet tried."
|
||
"*P"
|
||
(lambda (arg)
|
||
(define (do-abbrev loc abbrev old which)
|
||
(let ((do-case (and (ref-variable case-fold-search)
|
||
(ref-variable case-replace)))
|
||
(pattern (string-append "\\b"
|
||
(re-quote-string abbrev)
|
||
"\\(\\sw\\|\\s_\\)+")))
|
||
|
||
(define (search&setup-table count direction)
|
||
(let loop ((n count)
|
||
(expansion false)
|
||
(start
|
||
(or (ref-variable last-dabbrevs-expansion-location)
|
||
(current-point))))
|
||
(if (zero? n)
|
||
(values (mark-permanent-copy start) expansion)
|
||
(call-with-values
|
||
(lambda ()
|
||
(dabbrevs-search start pattern direction do-case))
|
||
(lambda (loc expansion)
|
||
(if (not expansion)
|
||
(values false false)
|
||
(begin
|
||
(set-variable!
|
||
last-dabbrev-table
|
||
(cons expansion
|
||
(ref-variable last-dabbrev-table)))
|
||
(loop (-1+ n) expansion loc))))))))
|
||
|
||
(define (step3 loc expansion)
|
||
(if (not expansion)
|
||
(let ((first (string=? abbrev old)))
|
||
(set-variable! last-dabbrevs-abbrev-location false)
|
||
(if (not first)
|
||
(let* ((end (current-point))
|
||
(start (mark- end (string-length old))))
|
||
(delete-string start end)
|
||
(insert-string abbrev start)))
|
||
(editor-error (if first
|
||
"No dynamic expansion found for "
|
||
"No further dynamic expansions found for ")
|
||
abbrev))
|
||
;; Success: stick it in and return.
|
||
;; Make case of replacement conform to case of abbreviation
|
||
;; provided (1) that kind of thing is enabled in this buffer
|
||
;; and (2) the replacement itself is all lower case
|
||
;; except perhaps for the first character.
|
||
(let ((place (search-backward old
|
||
(current-point)
|
||
(buffer-start (current-buffer))))
|
||
(do-case (and do-case
|
||
(substring-lower-case?
|
||
expansion
|
||
1
|
||
(string-length expansion)))))
|
||
;; First put back the original abbreviation with its original
|
||
;; case pattern.
|
||
(replace-match abbrev false true)
|
||
(search-forward abbrev
|
||
place
|
||
(buffer-end (current-buffer)))
|
||
(replace-match (if do-case
|
||
(string-downcase expansion)
|
||
expansion)
|
||
do-case
|
||
true)
|
||
;; Save state for re-expand.
|
||
(set-variable! last-dabbrevs-abbreviation abbrev)
|
||
(set-variable! last-dabbrevs-expansion expansion)
|
||
(set-variable! last-dabbrevs-expansion-location loc)
|
||
;; Chain invocations
|
||
(set-command-message! dabbrev-tag))))
|
||
|
||
(define (step2 loc expansion)
|
||
(if (or expansion (> which 0))
|
||
(step3 loc expansion)
|
||
;; Look forward
|
||
(call-with-values
|
||
(lambda () (search&setup-table (max 1 (- which)) false))
|
||
(lambda (loc expansion)
|
||
(set-variable! last-dabbrevs-direction -1)
|
||
(step3 loc expansion)))))
|
||
|
||
;; Try looking backward unless inhibited.
|
||
(if (< which 0)
|
||
(step2 loc false)
|
||
(call-with-values
|
||
(lambda () (search&setup-table (max 1 which) true))
|
||
(lambda (loc expansion)
|
||
(if (not expansion)
|
||
(set-variable! last-dabbrevs-expansion-location
|
||
false))
|
||
(set-variable! last-dabbrevs-direction (min 1 which))
|
||
(step2 loc expansion))))))
|
||
|
||
(define (do-from-scratch)
|
||
(let* ((loc (current-point))
|
||
(start (backward-word loc 1 'ERROR))
|
||
(abbrev (extract-string start loc)))
|
||
(set-variable! last-dabbrevs-abbrev-location start)
|
||
(set-variable! last-dabbrevs-expansion-location false)
|
||
(set-variable! last-dabbrev-table '())
|
||
(do-abbrev loc
|
||
abbrev
|
||
abbrev
|
||
(cond (arg
|
||
(command-argument-value arg))
|
||
((ref-variable dabbrevs-backward-only)
|
||
1)
|
||
(else
|
||
0)))))
|
||
|
||
(if (and (not arg)
|
||
(command-message-receive dabbrev-tag
|
||
(lambda () true)
|
||
(lambda () false))
|
||
(ref-variable last-dabbrevs-abbrev-location))
|
||
(do-abbrev false
|
||
(ref-variable last-dabbrevs-abbreviation)
|
||
(ref-variable last-dabbrevs-expansion)
|
||
(ref-variable last-dabbrevs-direction))
|
||
(do-from-scratch))))
|
||
|
||
;; Search function used by dabbrevs library.
|
||
;; pattern is string to find as prefix of word.
|
||
;; reverse? is true for reverse search, false for forward.
|
||
;; Variable abbrevs-limit controls the maximum search region size.
|
||
|
||
;; Table of expansions already seen is examined in buffer last-dabbrev-table,
|
||
;; so that only distinct possibilities are found by dabbrevs-re-expand.
|
||
;; Note that to prevent finding the abbrev itself it must have been
|
||
;; entered in the table.
|
||
|
||
;; Values are false if no expansion found.
|
||
;; After a succesful search, values are a mark right after the expansion,
|
||
;; and the expansion itself.
|
||
|
||
(define (dabbrevs-search start pattern reverse? do-case)
|
||
;; (values loc expansion)
|
||
(let ((limit (let ((limit (ref-variable dabbrevs-limit)))
|
||
(if limit
|
||
((if reverse? mark- mark+)
|
||
start
|
||
limit)
|
||
((if reverse? buffer-start buffer-end)
|
||
(current-buffer))))))
|
||
(let loop ((posn start))
|
||
(if (not ((if reverse? re-search-backward re-search-forward)
|
||
pattern posn limit))
|
||
(values false false)
|
||
(let ((start (re-match-start 0))
|
||
(end (re-match-end 0)))
|
||
(let* ((result (extract-string start end))
|
||
(test (if do-case
|
||
(string-downcase result)
|
||
result)))
|
||
(if (any (lambda (example)
|
||
(string=? test
|
||
(if do-case
|
||
(string-downcase example)
|
||
example)))
|
||
(ref-variable last-dabbrev-table))
|
||
(loop (if reverse? start end))
|
||
(values end result))))))))
|