1134 lines
36 KiB
Scheme
1134 lines
36 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.
|
||
|
||
|#
|
||
|
||
;;;; User Prompting
|
||
;;; Package: (edwin prompt)
|
||
|
||
|
||
|
||
(define typein-edit-abort-flag "Abort")
|
||
(define typein-edit-continuation)
|
||
(define typein-edit-depth)
|
||
(define typein-saved-buffers)
|
||
(define typein-saved-windows)
|
||
(define map-name/internal->external)
|
||
(define map-name/external->internal)
|
||
|
||
(add-event-receiver! editor-initializations
|
||
(lambda ()
|
||
(set! typein-edit-continuation #f)
|
||
(set! typein-edit-depth -1)
|
||
(set! typein-saved-buffers '())
|
||
(set! typein-saved-windows '())
|
||
(set! map-name/internal->external identity-procedure)
|
||
(set! map-name/external->internal identity-procedure)
|
||
(set! prompt-histories (make-key-weak-eq-hash-table))
|
||
unspecific))
|
||
|
||
(define (make-typein-buffer-name depth)
|
||
(string-append " *Typein-" (number->string depth) "*"))
|
||
|
||
(define (within-typein-edit thunk)
|
||
(let ((value
|
||
(call-with-current-continuation
|
||
(lambda (continuation)
|
||
(fluid-let ((typein-edit-continuation continuation)
|
||
(typein-edit-depth (1+ typein-edit-depth))
|
||
(typein-saved-buffers
|
||
(cons (window-buffer (typein-window))
|
||
typein-saved-buffers))
|
||
(typein-saved-windows
|
||
(cons (current-window)
|
||
typein-saved-windows)))
|
||
(dynamic-wind
|
||
(lambda () unspecific)
|
||
(lambda ()
|
||
(let ((window (typein-window)))
|
||
(select-window window)
|
||
(select-buffer
|
||
(find-or-create-buffer
|
||
(make-typein-buffer-name typein-edit-depth)))
|
||
(buffer-reset! (current-buffer))
|
||
(reset-command-prompt!)
|
||
(window-clear-override-message! window))
|
||
(thunk))
|
||
(lambda ()
|
||
(let ((window (typein-window)))
|
||
(select-window window)
|
||
(let ((buffer (car typein-saved-buffers)))
|
||
(bufferset-guarantee-buffer! (current-bufferset) buffer)
|
||
(select-buffer buffer))
|
||
(reset-command-prompt!)
|
||
(window-clear-override-message! window))
|
||
(if (zero? typein-edit-depth)
|
||
(buffer-reset! (current-buffer)))
|
||
(cond ((window-visible? (car typein-saved-windows))
|
||
(select-window (car typein-saved-windows)))
|
||
((zero? typein-edit-depth)
|
||
(select-window (other-window)))))))))))
|
||
(cond ((condition? value)
|
||
(signal-condition value))
|
||
((and (pair? value) (eq? (car value) typein-edit-abort-flag))
|
||
(apply-input-event (cdr value))
|
||
(within-typein-edit thunk))
|
||
(else
|
||
value))))
|
||
|
||
(define-integrable (within-typein-edit?)
|
||
(not (null? typein-saved-windows)))
|
||
|
||
(define (typein-edit-other-window)
|
||
(let loop ((windows typein-saved-windows))
|
||
(if (pair? windows)
|
||
(if (and (not (typein-window? (car windows)))
|
||
(window-visible? (car windows)))
|
||
(car windows)
|
||
(loop (cdr windows)))
|
||
(window0))))
|
||
|
||
(define-variable enable-recursive-minibuffers
|
||
"True means allow minibuffers to invoke commands that use recursive minibuffers."
|
||
#f
|
||
boolean?)
|
||
|
||
(define-variable completion-auto-help
|
||
"True means automatically provide help for invalid completion input."
|
||
#t
|
||
boolean?)
|
||
|
||
(define (prompt-for-typein prompt-string check-recursion? thunk)
|
||
(if (and check-recursion?
|
||
(not (ref-variable enable-recursive-minibuffers))
|
||
(typein-window? (current-window)))
|
||
(editor-error "Command attempted to use minibuffer while in minibuffer"))
|
||
(cleanup-pop-up-buffers
|
||
(lambda ()
|
||
(within-typein-edit
|
||
(lambda ()
|
||
(insert-string prompt-string)
|
||
(let ((mark (current-point)))
|
||
(with-text-clipped (mark-right-inserting mark)
|
||
(mark-left-inserting mark)
|
||
(lambda ()
|
||
(bind-condition-handler (list condition-type:^G)
|
||
(lambda (condition)
|
||
(cond ((not (eq? (current-window) (typein-window)))
|
||
(signal-condition condition))
|
||
(typein-edit-continuation
|
||
(typein-edit-continuation condition))
|
||
(else
|
||
(error "illegal ^G signaled in typein window"))))
|
||
thunk)))))))))
|
||
|
||
(define ((typein-editor-thunk mode))
|
||
(let ((buffer (current-buffer)))
|
||
(ring-clear! (buffer-mark-ring buffer))
|
||
(push-current-mark! (buffer-start buffer))
|
||
(if (major-mode? mode)
|
||
(set-buffer-major-mode! buffer mode)
|
||
(mode buffer)))
|
||
(command-reader))
|
||
|
||
(define (abort-typein-edit event)
|
||
(typein-edit-continuation (cons typein-edit-abort-flag event)))
|
||
|
||
(define (exit-typein-edit)
|
||
(if (not typein-edit-continuation)
|
||
(error "Not editing typein; can't exit"))
|
||
;; Indicate that typein has been accepted.
|
||
(let ((window (current-window)))
|
||
(window-home-cursor! window)
|
||
(typein-edit-continuation (buffer-string (window-buffer window)))))
|
||
|
||
(define-integrable (typein-string)
|
||
(map-name/external->internal (buffer-string (current-buffer))))
|
||
|
||
(define (set-typein-string! string #!optional update?)
|
||
(let ((dont-update?
|
||
(or (not (or (default-object? update?) update?))
|
||
(window-needs-redisplay? (typein-window)))))
|
||
(region-delete! (buffer-region (current-buffer)))
|
||
(insert-string (map-name/internal->external string))
|
||
(if (not dont-update?) (update-typein!))))
|
||
|
||
(define (update-typein!)
|
||
(if (not *executing-keyboard-macro?*)
|
||
(window-direct-update! (typein-window) #f)))
|
||
|
||
;;;; String Prompt
|
||
|
||
(define (prompt-for-string prompt default-string . options)
|
||
(%prompt-for-string
|
||
prompt
|
||
(parse-prompt-options
|
||
(basic-prompt-options (ref-mode-object minibuffer-local)
|
||
default-string)
|
||
options)))
|
||
|
||
(define (prompt-for-completed-string prompt
|
||
default-string
|
||
complete-string
|
||
list-completions
|
||
verify-final-value
|
||
. options)
|
||
(%prompt-for-string
|
||
prompt
|
||
(parse-prompt-options
|
||
(completion-prompt-options (ref-mode-object minibuffer-local-completion)
|
||
default-string
|
||
complete-string
|
||
list-completions
|
||
verify-final-value)
|
||
options)))
|
||
|
||
(define *options*)
|
||
|
||
(define (%prompt-for-string prompt options)
|
||
(fluid-let ((*options* options))
|
||
(let ((type (default-type))
|
||
(string (default-string)))
|
||
(let ((initial-string
|
||
(if (and string (eq? type 'INSERTED-DEFAULT))
|
||
string
|
||
"")))
|
||
(with-history-state initial-string
|
||
(lambda ()
|
||
(prompt-for-typein
|
||
(prompt-for-string/prompt prompt
|
||
(and string
|
||
(eq? 'VISIBLE-DEFAULT type)
|
||
(write-to-string string)))
|
||
#t
|
||
(let ((thunk (typein-editor-thunk (options/mode *options*))))
|
||
(lambda ()
|
||
(insert-string initial-string)
|
||
((thunk)))))))))))
|
||
|
||
(define (default-type) (options/default-type *options*))
|
||
(define (default-string) (options/default-string *options*))
|
||
|
||
(define (case-insensitive-completion?)
|
||
(options/case-insensitive-completion? *options*))
|
||
|
||
(define (prompt-for-string/prompt prompt default-string)
|
||
(cond ((string? prompt)
|
||
(string-append
|
||
prompt
|
||
(if default-string
|
||
(string-append " (default is: " default-string ")")
|
||
"")
|
||
(if (string-suffix? " " prompt)
|
||
""
|
||
": ")))
|
||
((and (pair? prompt)
|
||
(string? (car prompt))
|
||
(null? (cdr prompt)))
|
||
(car prompt))
|
||
(else
|
||
(error:wrong-type-argument prompt
|
||
"prompt string"
|
||
'PROMPT-FOR-STRING/PROMPT))))
|
||
|
||
(define (prompt-for-number prompt default . options)
|
||
(let ((string
|
||
(apply prompt-for-string
|
||
prompt
|
||
(and default (number->string default))
|
||
options)))
|
||
(or (string->number string)
|
||
(editor-error "Input not a number: " string))))
|
||
|
||
(define (prompt-for-string-table-name prompt default-string string-table
|
||
. options)
|
||
(apply prompt-for-completed-string
|
||
prompt
|
||
default-string
|
||
(lambda (string if-unique if-not-unique if-not-found)
|
||
(string-table-complete string-table
|
||
string
|
||
if-unique
|
||
if-not-unique
|
||
if-not-found))
|
||
(lambda (string)
|
||
(string-table-completions string-table string))
|
||
(lambda (string)
|
||
(let ((default (list 'DEFAULT)))
|
||
(not (eq? (string-table-get string-table string
|
||
(lambda (index) index default))
|
||
default))))
|
||
'CASE-INSENSITIVE-COMPLETION? (string-table-ci? string-table)
|
||
options))
|
||
|
||
(define (prompt-for-string-table-value prompt default-string string-table
|
||
. options)
|
||
(string-table-get string-table
|
||
(apply prompt-for-string-table-name
|
||
prompt default-string string-table
|
||
options)))
|
||
|
||
(define (prompt-for-alist-value prompt alist #!optional default ci?)
|
||
(fluid-let ((map-name/external->internal identity-procedure)
|
||
(map-name/internal->external identity-procedure))
|
||
(prompt-for-string-table-value prompt
|
||
(and (not (default-object? default))
|
||
default)
|
||
(alist->string-table
|
||
alist
|
||
(if (default-object? ci?) #t ci?))
|
||
'REQUIRE-MATCH? #t)))
|
||
|
||
(define (prompt-for-command prompt . options)
|
||
(fluid-let ((map-name/external->internal editor-name/external->internal)
|
||
(map-name/internal->external editor-name/internal->external))
|
||
(apply prompt-for-string-table-value prompt #f editor-commands
|
||
'DEFAULT-TYPE 'NO-DEFAULT
|
||
'REQUIRE-MATCH? #t
|
||
options)))
|
||
|
||
(define (prompt-for-variable prompt . options)
|
||
(fluid-let ((map-name/external->internal editor-name/external->internal)
|
||
(map-name/internal->external editor-name/internal->external))
|
||
(apply prompt-for-string-table-value prompt #f editor-variables
|
||
'DEFAULT-TYPE 'NO-DEFAULT
|
||
'REQUIRE-MATCH? #t
|
||
options)))
|
||
|
||
;;;; Prompt Options
|
||
|
||
(define-structure
|
||
(prompt-options (conc-name options/)
|
||
(constructor basic-prompt-options
|
||
(mode default-string))
|
||
(constructor completion-prompt-options
|
||
(mode default-string
|
||
complete-string
|
||
list-completions
|
||
verify-final-value)))
|
||
(seen '())
|
||
(mode #f)
|
||
(default-string #f)
|
||
(complete-string #f read-only #t)
|
||
(list-completions #f read-only #t)
|
||
(verify-final-value #f read-only #t)
|
||
(default-type 'VISIBLE-DEFAULT)
|
||
(require-match? #f)
|
||
(case-insensitive-completion? #f)
|
||
(history #f)
|
||
(history-index -1))
|
||
|
||
(define (parse-prompt-options option-structure options)
|
||
(let loop ((options options))
|
||
(cond ((and (pair? options)
|
||
(symbol? (car options))
|
||
(pair? (cdr options)))
|
||
(let ((entry (assq (car options) prompt-options-table))
|
||
(arg (cadr options)))
|
||
(if (not entry)
|
||
(error "Unknown prompt option:" (car options)))
|
||
(set-options/seen! option-structure
|
||
(cons (car options)
|
||
(options/seen option-structure)))
|
||
(if (not (let ((predicate (cadr entry)))
|
||
(if (pair? predicate)
|
||
(any (lambda (p) (p arg)) predicate)
|
||
(predicate arg))))
|
||
(error "Not a valid option argument:" arg))
|
||
((cddr entry) option-structure arg)
|
||
(loop (cddr options))))
|
||
((null? options)
|
||
option-structure)
|
||
(else
|
||
(error "Illegal options tail:" options)))))
|
||
|
||
(define (lookup-prompt-option options keyword default)
|
||
;; If there are multiple instances of KEYWORD, return the last.
|
||
(let loop ((options options) (winner #f))
|
||
(if (pair? options)
|
||
(begin
|
||
(if (not (pair? (cdr options)))
|
||
(error "Options list has odd length:" options))
|
||
(loop (cddr options)
|
||
(if (eq? keyword (car options)) options winner)))
|
||
(begin
|
||
(if (not (null? options))
|
||
(error "Illegal options tail:" options))
|
||
(if winner
|
||
(cadr winner)
|
||
default)))))
|
||
|
||
(define prompt-options-table
|
||
'())
|
||
|
||
(define (define-prompt-option keyword type modifier)
|
||
(let ((entry (assq keyword prompt-options-table))
|
||
(body (cons type modifier)))
|
||
(if entry
|
||
(set-cdr! entry body)
|
||
(begin
|
||
(set! prompt-options-table
|
||
(cons (cons keyword body)
|
||
prompt-options-table))
|
||
unspecific))))
|
||
|
||
(define (define-simple-option keyword type)
|
||
(define-prompt-option keyword type
|
||
(lambda (options value)
|
||
((record-modifier (record-type-descriptor options) keyword)
|
||
options
|
||
value))))
|
||
|
||
(define-simple-option 'MODE (list major-mode? procedure?))
|
||
(define-simple-option 'DEFAULT-STRING string-or-false?)
|
||
(define-simple-option 'CASE-INSENSITIVE-COMPLETION? boolean?)
|
||
|
||
(define-simple-option 'DEFAULT-TYPE
|
||
(lambda (object)
|
||
(memq object
|
||
'(VISIBLE-DEFAULT
|
||
INVISIBLE-DEFAULT
|
||
INSERTED-DEFAULT
|
||
NULL-DEFAULT
|
||
NO-DEFAULT))))
|
||
|
||
(define-prompt-option 'REQUIRE-MATCH?
|
||
(lambda (object)
|
||
(or (boolean? object)
|
||
(eq? 'CONFIRM object)))
|
||
(lambda (options require-match?)
|
||
(if require-match?
|
||
(set-options/mode! options
|
||
(ref-mode-object minibuffer-local-must-match)))
|
||
(set-options/require-match?! options require-match?)))
|
||
|
||
(define (options/confirm-completion? options)
|
||
(eq? 'CONFIRM (options/require-match? options)))
|
||
|
||
;;;; Prompt History Mechanism
|
||
|
||
(define *history-items*)
|
||
(define *history-index*)
|
||
|
||
(define (with-history-state initial-string thunk)
|
||
(let ((history (name->history (options/history *options*))))
|
||
(fluid-let ((*history-items*
|
||
(cons initial-string (list-copy (cdr history))))
|
||
(*history-index* (+ 1 (options/history-index *options*))))
|
||
(if (< *history-index* 0)
|
||
(set! *history-index* 0)
|
||
(let ((hl (length *history-items*)))
|
||
(if (>= *history-index* hl)
|
||
(set! *history-index* (- hl 1)))))
|
||
(let ((string (thunk)))
|
||
(if (not (and (pair? (cdr history))
|
||
(string=? string (car (cdr history)))))
|
||
(set-cdr! history (cons string (cdr history))))
|
||
string))))
|
||
|
||
(define prompt-histories)
|
||
|
||
(define (name->history name)
|
||
(if (not (or (not name) (symbol? name)))
|
||
(error:wrong-type-argument name "symbol" 'NAME->HISTORY))
|
||
(let ((name (or name 'MINIBUFFER-DEFAULT)))
|
||
(or (hash-table-ref/default prompt-histories name #f)
|
||
(let ((history (list 'PROMPT-HISTORY)))
|
||
(hash-table-set! prompt-histories name history)
|
||
history))))
|
||
|
||
(define (prompt-history-strings name)
|
||
(list-copy (cdr (name->history name))))
|
||
|
||
(define (set-prompt-history-strings! name strings)
|
||
(if (not (list-of-strings? strings))
|
||
(error:wrong-type-argument strings "list of strings"
|
||
'SET-PROMPT-HISTORY-STRINGS!))
|
||
(set-cdr! (name->history name) (list-copy strings)))
|
||
|
||
(define-simple-option 'HISTORY symbol?)
|
||
|
||
(define-prompt-option 'HISTORY-INDEX exact-nonnegative-integer?
|
||
(lambda (options index)
|
||
(set-options/history-index! options index)
|
||
(history->default-string options)))
|
||
|
||
(define (history->default-string options)
|
||
(let ((history (name->history (options/history options)))
|
||
(index (options/history-index options)))
|
||
(if (and (not (options/default-string options))
|
||
(not (memq 'DEFAULT-STRING (options/seen options)))
|
||
(let ((length (length (cdr history))))
|
||
(and (> length 0)
|
||
(< index length))))
|
||
(set-options/default-string! options (list-ref (cdr history) index)))))
|
||
|
||
(define (prompt-options-default-string options)
|
||
(or (lookup-prompt-option options 'DEFAULT-STRING #f)
|
||
(let ((index (lookup-prompt-option options 'HISTORY-INDEX #f)))
|
||
(and index
|
||
(<= 0 index)
|
||
(let ((strings
|
||
(cdr
|
||
(name->history
|
||
(lookup-prompt-option options 'HISTORY #f)))))
|
||
(and (< index (length strings))
|
||
(list-ref strings index)))))))
|
||
|
||
;;;; String Prompt Modes
|
||
|
||
(define-major-mode minibuffer-local fundamental #f
|
||
"Major mode for editing solicited input strings.
|
||
The following commands are special to this mode:
|
||
|
||
\\[exit-minibuffer] terminates the input.
|
||
\\[minibuffer-yank-default] yanks the default string, if there is one.
|
||
\\[next-prompt-history-item] moves to the next item in the history.
|
||
\\[previous-prompt-history-item] moves to the previous item in the history.")
|
||
|
||
(define-key 'minibuffer-local #\return 'exit-minibuffer)
|
||
(define-key 'minibuffer-local #\linefeed 'exit-minibuffer)
|
||
(define-key 'minibuffer-local #\c-m-y 'minibuffer-yank-default)
|
||
(define-key 'minibuffer-local #\M-n 'next-prompt-history-item)
|
||
(define-key 'minibuffer-local #\M-p 'previous-prompt-history-item)
|
||
|
||
(define-major-mode minibuffer-local-completion minibuffer-local #f
|
||
(description-append (mode-description (ref-mode-object minibuffer-local))
|
||
"
|
||
\\[minibuffer-complete] completes as much of the input as possible.
|
||
\\[minibuffer-complete-word] completes the next word of the input.
|
||
\\[minibuffer-completion-help] displays possible completions of the input."))
|
||
|
||
(define-key 'minibuffer-local-completion #\tab 'minibuffer-complete)
|
||
(define-key 'minibuffer-local-completion #\space 'minibuffer-complete-word)
|
||
(define-key 'minibuffer-local-completion #\? 'minibuffer-completion-help)
|
||
|
||
(define-major-mode minibuffer-local-must-match minibuffer-local-completion #f
|
||
(mode-description (ref-mode-object minibuffer-local-completion)))
|
||
|
||
(define-key 'minibuffer-local-must-match #\return
|
||
'minibuffer-complete-and-exit)
|
||
(define-key 'minibuffer-local-must-match #\linefeed
|
||
'minibuffer-complete-and-exit)
|
||
|
||
(define-command exit-minibuffer
|
||
"Terminate this minibuffer argument."
|
||
()
|
||
(lambda ()
|
||
(cond ((not (string-null? (typein-string)))
|
||
(call-with-current-continuation
|
||
(lambda (k)
|
||
;; Run the final value verification, just to catch any
|
||
;; errors that it might generate.
|
||
(verify-final-value k)
|
||
(exit-typein-edit))))
|
||
((memq (default-type) '(NULL-DEFAULT INSERTED-DEFAULT))
|
||
(exit-typein-edit))
|
||
((or (not (default-string))
|
||
(eq? (default-type) 'NO-DEFAULT))
|
||
(editor-failure))
|
||
(else
|
||
(if (and (memq (default-type) '(INVISIBLE-DEFAULT VISIBLE-DEFAULT))
|
||
(default-string))
|
||
(set-typein-string! (default-string) #f))
|
||
(exit-typein-edit)))))
|
||
|
||
(define-command minibuffer-yank-default
|
||
"Insert the default string at point."
|
||
()
|
||
(lambda ()
|
||
(if (default-string)
|
||
(insert-string (default-string))
|
||
(editor-failure))))
|
||
|
||
(define-command minibuffer-complete
|
||
"Complete the minibuffer contents as far as possible."
|
||
()
|
||
(lambda ()
|
||
(case (complete-input-string (options/complete-string *options*) #t)
|
||
((WAS-ALREADY-EXACT-AND-UNIQUE-COMPLETION)
|
||
(temporary-typein-message " [Sole completion]"))
|
||
((WAS-ALREADY-EXACT-COMPLETION)
|
||
(temporary-typein-message " [Complete, but not unique]")))))
|
||
|
||
(define-command minibuffer-complete-word
|
||
"Complete the minibuffer contents at most a single word."
|
||
()
|
||
(lambda ()
|
||
(case (complete-input-string completion-procedure/complete-word #t)
|
||
((WAS-ALREADY-EXACT-AND-UNIQUE-COMPLETION)
|
||
(temporary-typein-message " [Sole completion]"))
|
||
((WAS-ALREADY-EXACT-COMPLETION)
|
||
(temporary-typein-message " [Complete, but not unique]")))))
|
||
|
||
(define-command minibuffer-completion-help
|
||
"Display a list of possible completions of the current minibuffer contents."
|
||
()
|
||
(lambda ()
|
||
(minibuffer-completion-help
|
||
(lambda ()
|
||
(with-messages-suppressed
|
||
(lambda ()
|
||
((options/list-completions *options*) (typein-string))))))))
|
||
|
||
(define (minibuffer-completion-help list-completions)
|
||
(pop-up-generated-completions
|
||
(lambda ()
|
||
(map map-name/internal->external (list-completions)))))
|
||
|
||
(define-command minibuffer-complete-and-exit
|
||
"Complete the minibuffer contents, and maybe exit.
|
||
Exit if the name is valid with no completion needed.
|
||
If name was completed to a valid match,
|
||
a repetition of this command will exit."
|
||
()
|
||
(lambda ()
|
||
(let ((string (typein-string)))
|
||
(if (and (string-null? string)
|
||
(memq (default-type) '(INVISIBLE-DEFAULT VISIBLE-DEFAULT))
|
||
(default-string))
|
||
(set-typein-string! (default-string) #f)))
|
||
(call-with-current-continuation
|
||
(lambda (k)
|
||
(if (verify-final-value k)
|
||
(exit-typein-edit)
|
||
(case (complete-input-string (options/complete-string *options*)
|
||
#f)
|
||
((WAS-ALREADY-EXACT-AND-UNIQUE-COMPLETION
|
||
WAS-ALREADY-EXACT-COMPLETION)
|
||
(exit-typein-edit))
|
||
((COMPLETED-TO-EXACT-AND-UNIQUE-COMPLETION
|
||
COMPLETED-TO-EXACT-COMPLETION)
|
||
(if (options/confirm-completion? *options*)
|
||
(temporary-typein-message " [Confirm]")
|
||
(exit-typein-edit)))
|
||
(else
|
||
(update-typein!)
|
||
(editor-failure))))))))
|
||
|
||
(define (verify-final-value error-continuation)
|
||
(let ((verifier (options/verify-final-value *options*)))
|
||
(if verifier
|
||
(bind-condition-handler (list condition-type:error)
|
||
(lambda (condition)
|
||
condition
|
||
(editor-failure)
|
||
(temporary-typein-message " [Error]")
|
||
(error-continuation unspecific))
|
||
(lambda () (verifier (typein-string))))
|
||
#t)))
|
||
|
||
;;;; Completion Primitives
|
||
|
||
(define (complete-input-string complete-string update?)
|
||
(call-with-current-continuation
|
||
(lambda (k)
|
||
(let ((original (typein-string))
|
||
(effected? #f))
|
||
(let ((finish
|
||
(lambda (string not-completed completed list-completions)
|
||
(let ((verified?
|
||
((options/verify-final-value *options*) string)))
|
||
(set! effected? #t)
|
||
(if (not (string=? string original))
|
||
(set-typein-string! string update?))
|
||
(if verified?
|
||
(if (if (case-insensitive-completion?)
|
||
(string-ci=? string original)
|
||
(string=? string original))
|
||
not-completed
|
||
completed)
|
||
(if (if (case-insensitive-completion?)
|
||
(string-ci=? string original)
|
||
(string=? string original))
|
||
(begin
|
||
(if list-completions
|
||
(if (ref-variable completion-auto-help)
|
||
(minibuffer-completion-help
|
||
list-completions)
|
||
(temporary-typein-message
|
||
" [Next char not unique]")))
|
||
'NO-COMPLETION-HAPPENED)
|
||
'SOME-COMPLETION-HAPPENED))))))
|
||
(bind-condition-handler (list condition-type:error)
|
||
(lambda (condition)
|
||
condition
|
||
(if (not effected?)
|
||
(begin
|
||
(editor-failure)
|
||
(temporary-typein-message " [Error]")
|
||
(k 'NO-MATCH))))
|
||
(lambda ()
|
||
(with-messages-suppressed
|
||
(lambda ()
|
||
(complete-string original
|
||
(lambda (string)
|
||
(finish string
|
||
'WAS-ALREADY-EXACT-AND-UNIQUE-COMPLETION
|
||
'COMPLETED-TO-EXACT-AND-UNIQUE-COMPLETION
|
||
#f))
|
||
(lambda (string list-completions)
|
||
(finish string
|
||
'WAS-ALREADY-EXACT-COMPLETION
|
||
'COMPLETED-TO-EXACT-COMPLETION
|
||
list-completions))
|
||
(lambda ()
|
||
(set! effected? #t)
|
||
(editor-beep)
|
||
(temporary-typein-message " [No match]")
|
||
'NO-MATCH)))))))))))
|
||
|
||
(define (completion-procedure/complete-word string
|
||
if-unique
|
||
if-not-unique
|
||
if-not-found)
|
||
(let ((truncate-string
|
||
(lambda (new-string)
|
||
(let ((end (string-length new-string)))
|
||
(let ((index
|
||
(and (if (case-insensitive-completion?)
|
||
(string-prefix-ci? string new-string)
|
||
(string-prefix? string new-string))
|
||
(substring-find-next-char-not-of-syntax
|
||
new-string (string-length string) end
|
||
(ref-variable syntax-table) #\w))))
|
||
(if index
|
||
(substring new-string 0 (1+ index))
|
||
new-string))))))
|
||
(let ((if-unique
|
||
(lambda (new-string)
|
||
(if-unique (truncate-string new-string))))
|
||
(if-not-unique
|
||
(lambda (new-string list-completions)
|
||
(if-not-unique (truncate-string new-string) list-completions))))
|
||
((options/complete-string *options*) string
|
||
if-unique
|
||
(lambda (new-string list-completions)
|
||
(if (= (string-length new-string) (string-length string))
|
||
(let ((completions (list-completions)))
|
||
(let ((try-suffix
|
||
(lambda (suffix if-not-found)
|
||
(let ((completions
|
||
(filter (let ((prefix
|
||
(string-append string suffix)))
|
||
(if (case-insensitive-completion?)
|
||
(lambda (completion)
|
||
(string-prefix-ci? prefix
|
||
completion))
|
||
(lambda (completion)
|
||
(string-prefix? prefix
|
||
completion))))
|
||
completions)))
|
||
(cond ((null? completions)
|
||
(if-not-found))
|
||
((null? (cdr completions))
|
||
(if-unique (car completions)))
|
||
(else
|
||
(if-not-unique
|
||
((if (case-insensitive-completion?)
|
||
string-greatest-common-prefix-ci
|
||
string-greatest-common-prefix)
|
||
completions)
|
||
(lambda () completions))))))))
|
||
(try-suffix "-"
|
||
(lambda ()
|
||
(try-suffix " "
|
||
(lambda ()
|
||
(if-not-unique string (lambda () completions))))))))
|
||
(if-not-unique new-string list-completions)))
|
||
if-not-found))))
|
||
|
||
;;;; Support for Completion
|
||
|
||
(define (standard-completion prefix complete-string insert-completed-string)
|
||
(let ((insert-completed-string
|
||
(lambda (completion)
|
||
(insert-completed-string completion)
|
||
(completion-message ""))))
|
||
(complete-string prefix
|
||
(lambda (completion)
|
||
(if (not (string=? prefix completion))
|
||
(insert-completed-string completion)
|
||
(completion-message "Sole completion"))
|
||
(flush-completions-list))
|
||
(lambda (completion generate-completions)
|
||
(cond ((not (string=? prefix completion))
|
||
(insert-completed-string completion)
|
||
(flush-completions-list))
|
||
((ref-variable completion-auto-help)
|
||
(pop-up-generated-completions generate-completions))
|
||
(else
|
||
(completion-message "Next char not unique"))))
|
||
(lambda ()
|
||
(editor-beep)
|
||
(completion-message "No completions")
|
||
(flush-completions-list)))))
|
||
|
||
(define (pop-up-generated-completions generate-completions)
|
||
(message "Making completion list...")
|
||
(call-with-current-continuation
|
||
(lambda (k)
|
||
(let ((completions
|
||
(bind-condition-handler (list condition-type:error)
|
||
(lambda (condition)
|
||
condition
|
||
(clear-message)
|
||
(editor-beep)
|
||
(completion-message "Error")
|
||
(k unspecific))
|
||
generate-completions)))
|
||
(clear-message)
|
||
(if (null? completions)
|
||
(begin
|
||
(editor-beep)
|
||
(completion-message "No completions"))
|
||
(pop-up-completions-list completions))))))
|
||
|
||
(define (pop-up-completions-list strings)
|
||
(with-output-to-temporary-buffer " *Completions*"
|
||
'(SHRINK-WINDOW FLUSH-ON-SPACE)
|
||
(lambda ()
|
||
(write-completions-list strings))))
|
||
|
||
(define (write-completions-list strings)
|
||
(if (null? strings)
|
||
(write-string
|
||
"There are no possible completions of what you have typed.")
|
||
(begin
|
||
(write-string "Possible completions are:\n")
|
||
(write-strings-densely strings))))
|
||
|
||
(define (flush-completions-list)
|
||
(maybe-kill-pop-up-buffer (find-buffer " *Completions*")))
|
||
|
||
(define (completion-message string)
|
||
(if (typein-window? (current-window))
|
||
(if (not (string-null? string))
|
||
(temporary-typein-message (string-append " [" string "]")))
|
||
(message string)))
|
||
|
||
(define (temporary-typein-message string)
|
||
(let ((point) (start) (end))
|
||
(dynamic-wind (lambda ()
|
||
(set! point (current-point))
|
||
(set! end (buffer-end (current-buffer)))
|
||
(set! start (mark-right-inserting end))
|
||
unspecific)
|
||
(lambda ()
|
||
(insert-string string start)
|
||
(set-current-point! start)
|
||
(sit-for 2000))
|
||
(lambda ()
|
||
(delete-string start end)
|
||
(set-current-point! point)))))
|
||
|
||
;;;; Character Prompts
|
||
|
||
(define (prompt-for-char prompt)
|
||
(let ((input
|
||
(prompt-for-typein (string-append prompt ": ") #f
|
||
(lambda ()
|
||
(let ((input (with-editor-interrupts-disabled keyboard-read)))
|
||
(if (ascii-char? input)
|
||
(set-typein-string! (key-name input) #t))
|
||
(if (input-event? input)
|
||
(abort-typein-edit input)
|
||
input))))))
|
||
(if (not (ascii-char? input))
|
||
(editor-error "Not an ASCII character:" input))
|
||
input))
|
||
|
||
(define (prompt-for-key prompt #!optional comtab)
|
||
(let ((comtab (if (default-object? comtab) (current-comtabs) comtab)))
|
||
(prompt-for-typein (string-append prompt ": ") #f
|
||
(lambda ()
|
||
(let outer-loop ((prefix '()))
|
||
(let inner-loop
|
||
((char (with-editor-interrupts-disabled keyboard-read)))
|
||
(if (input-event? char)
|
||
(abort-typein-edit char))
|
||
(let ((chars (append! prefix (list char))))
|
||
(set-typein-string! (xkey->name chars) #t)
|
||
(if (prefix-key-list? comtab chars)
|
||
(outer-loop chars)
|
||
(let ((command (comtab-entry comtab chars)))
|
||
(if (memq command extension-commands)
|
||
(inner-loop
|
||
(fluid-let ((execute-extended-keys? #f))
|
||
(dispatch-on-command command)))
|
||
chars))))))))))
|
||
|
||
;;;; Confirmation Prompts
|
||
|
||
(define (prompt-for-confirmation? prompt)
|
||
(prompt-for-typein (if (string-suffix? " " prompt)
|
||
prompt
|
||
(string-append prompt " (y or n)? "))
|
||
#f
|
||
(lambda ()
|
||
(let loop ((lost? #f))
|
||
(let ((char (keyboard-read)))
|
||
(cond ((and (char? char)
|
||
(or (char-ci=? char #\y)
|
||
(char-ci=? char #\space)))
|
||
(set-typein-string! "y" #t)
|
||
#t)
|
||
((and (char? char)
|
||
(or (char-ci=? char #\n)
|
||
(char-ci=? char #\rubout)))
|
||
(set-typein-string! "n" #t)
|
||
#f)
|
||
((input-event? char)
|
||
(abort-typein-edit char))
|
||
(else
|
||
(editor-beep)
|
||
(if (not lost?)
|
||
(insert-string "Please answer y or n. "
|
||
(buffer-absolute-start (current-buffer))))
|
||
(loop #t))))))))
|
||
|
||
(define (prompt-for-yes-or-no? prompt)
|
||
(string-ci=?
|
||
"Yes"
|
||
(prompt-for-typein (string-append prompt " (yes or no)? ") #t
|
||
(typein-editor-thunk (ref-mode-object minibuffer-local-yes-or-no)))))
|
||
|
||
(define-major-mode minibuffer-local-yes-or-no fundamental #f
|
||
"Enter either \"yes\" or \"no\".")
|
||
|
||
(define-key 'minibuffer-local-yes-or-no #\return 'exit-minibuffer-yes-or-no)
|
||
|
||
(define-command exit-minibuffer-yes-or-no
|
||
"Like \\[exit-minibuffer], but insists on \"yes\" or \"no\" as an answer."
|
||
()
|
||
(lambda ()
|
||
(let ((string (typein-string)))
|
||
(if (or (string-ci=? "yes" string)
|
||
(string-ci=? "no" string))
|
||
(exit-typein-edit)
|
||
(begin
|
||
(editor-beep)
|
||
(message "Please answer yes or no.")
|
||
(sit-for 2000)
|
||
(clear-message)
|
||
(set-typein-string! "" #f))))))
|
||
|
||
;;;; Prompt History
|
||
|
||
(define-command next-prompt-history-item
|
||
"Inserts the next item of the prompt history into the minibuffer.
|
||
The next item is the one more recent than the current item.
|
||
Has no effect if there is no history associated with this prompt.
|
||
With argument, skips forward that many items in the history."
|
||
"p"
|
||
(lambda (argument)
|
||
(if (and (not (null? *history-items*))
|
||
(not (zero? argument)))
|
||
(let* ((hl (length *history-items*))
|
||
(index
|
||
(let ((index (- *history-index* argument)))
|
||
(cond ((< index 0) 0)
|
||
((>= index hl) (- hl 1))
|
||
(else index)))))
|
||
(set-car! (drop *history-items* *history-index*)
|
||
(typein-string))
|
||
(set! *history-index* index)
|
||
(set-typein-string! (list-ref *history-items* *history-index*) #t)
|
||
(set-current-point! (buffer-start (current-buffer)))))))
|
||
|
||
(define-command previous-prompt-history-item
|
||
"Inserts the previous item of the prompt history into the minibuffer.
|
||
The previous item is the one less recent than the current item.
|
||
Has no effect if there is no history associated with this prompt.
|
||
With argument, skips backward that many items in the history."
|
||
"p"
|
||
(lambda (argument)
|
||
((ref-command next-prompt-history-item) (- argument))))
|
||
|
||
(define-command repeat-complex-command
|
||
"Edit and re-evaluate last complex command, or ARGth from last.
|
||
A complex command is one which used the minibuffer.
|
||
The command is placed in the minibuffer as a Scheme form for editing.
|
||
The result is executed, repeating the command as changed.
|
||
If the command has been changed or is not the most recent previous command
|
||
it is added to the front of the command history."
|
||
"p"
|
||
(lambda (argument)
|
||
;; Kludge.
|
||
(set-prompt-history-strings!
|
||
'REPEAT-COMPLEX-COMMAND
|
||
(map (lambda (command)
|
||
(parameterize ((param:print-with-maximum-readability? #t))
|
||
(write-to-string command)))
|
||
(command-history-list)))
|
||
(execute-command-history-entry
|
||
(read-from-string
|
||
(prompt-for-string "Redo" #f
|
||
'DEFAULT-TYPE 'INSERTED-DEFAULT
|
||
'HISTORY 'REPEAT-COMPLEX-COMMAND
|
||
'HISTORY-INDEX (- argument 1))))))
|
||
|
||
;;;; Pass-phrase Prompts
|
||
|
||
;;; Hair to make sure pass phrases aren't left around in memory.
|
||
|
||
(define (call-with-pass-phrase prompt receiver)
|
||
(let ((phrase)
|
||
(phrase*))
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(set! phrase "")
|
||
(set! phrase* #f)
|
||
unspecific)
|
||
(lambda ()
|
||
(prompt-for-typein (if (string-suffix? " " prompt)
|
||
prompt
|
||
(string-append prompt ": "))
|
||
#f
|
||
(lambda ()
|
||
(let loop ()
|
||
(set-typein-string! (make-string (string-length phrase) #\.) #t)
|
||
(let ((input (keyboard-read #t)))
|
||
(cond ((input-event? input)
|
||
(abort-typein-edit input))
|
||
((eqv? input #\return)
|
||
(receiver phrase))
|
||
(else
|
||
(cond ((eqv? input #\rubout)
|
||
(let ((length (string-length phrase)))
|
||
(if (fix:> length 0)
|
||
(let ((length (fix:- length 1)))
|
||
(set! phrase* phrase)
|
||
(set! phrase (string-head phrase length))
|
||
(string-fill! phrase* #\NUL)
|
||
(set! phrase* #f)))))
|
||
((ascii-char? input)
|
||
(set! phrase* phrase)
|
||
(set! phrase
|
||
(string-append phrase (string input)))
|
||
(string-fill! phrase* #\NUL)
|
||
(set! phrase* #f)))
|
||
(loop))))))))
|
||
(lambda ()
|
||
(string-fill! phrase #\NUL)
|
||
(set! phrase)
|
||
(if phrase* (string-fill! phrase* #\NUL))
|
||
(set! phrase*)
|
||
unspecific))))
|
||
|
||
(define (call-with-confirmed-pass-phrase receiver)
|
||
(call-with-pass-phrase "Pass phrase"
|
||
(lambda (p1)
|
||
(call-with-pass-phrase "Verify pass phrase"
|
||
(lambda (p2)
|
||
(if (not (string=? p1 p2))
|
||
(editor-error "Pass phrases do not match."))))
|
||
(receiver p1))))
|
||
|
||
;;;;; Stored Pass Phrases
|
||
|
||
(define-variable pass-phrase-retention-time
|
||
"The amount of time, in minutes, that Edwin retains pass phrases.
|
||
The pass phrase is deleted if unused for this long.
|
||
Set this to zero if you don't want pass-phrase retention."
|
||
30
|
||
exact-nonnegative-integer?)
|
||
|
||
(define (call-with-stored-pass-phrase key receiver)
|
||
(let ((retention-time (ref-variable pass-phrase-retention-time #f)))
|
||
(let ((entry (hash-table-ref/default stored-pass-phrases key #f)))
|
||
(if entry
|
||
(begin
|
||
(without-interrupts
|
||
(lambda ()
|
||
(deregister-timer-event (vector-ref entry 1))
|
||
(set-up-pass-phrase-timer! entry key retention-time)))
|
||
(call-with-unobscured-pass-phrase (vector-ref entry 0) receiver))
|
||
(call-with-pass-phrase
|
||
(string-append "Pass phrase for " key)
|
||
(lambda (pass-phrase)
|
||
(if (> retention-time 0)
|
||
(hash-table-set!
|
||
stored-pass-phrases
|
||
key
|
||
(let ((entry
|
||
(vector (obscure-pass-phrase pass-phrase) #f #f)))
|
||
(set-up-pass-phrase-timer! entry key retention-time)
|
||
entry)))
|
||
(receiver pass-phrase)))))))
|
||
|
||
(define (delete-stored-pass-phrase key)
|
||
(hash-table-delete! stored-pass-phrases key))
|
||
|
||
(define (set-up-pass-phrase-timer! entry key retention-time)
|
||
;; A race condition can occur when the timer event is re-registered.
|
||
;; If the previous timer event is queued but not executed before
|
||
;; being deregistered, then it will run after the re-registration
|
||
;; and try to delete the record. By matching on ID, the previous
|
||
;; event sees that it has been superseded and does nothing.
|
||
(let ((id (list 'ID)))
|
||
(vector-set! entry 2 id)
|
||
(vector-set! entry 1
|
||
(register-timer-event (* retention-time 60000)
|
||
(lambda ()
|
||
(without-interrupts
|
||
(lambda ()
|
||
(let ((entry (hash-table-ref/default stored-pass-phrases key #f)))
|
||
(if (and entry (eq? (vector-ref entry 2) id))
|
||
(hash-table-delete! stored-pass-phrases key))))))))))
|
||
|
||
(define stored-pass-phrases
|
||
(make-string-hash-table))
|
||
|
||
(define (obscure-pass-phrase clear-text)
|
||
(let ((n (string-length clear-text)))
|
||
(let ((noise (random-byte-vector n)))
|
||
(let ((obscured-text (make-string (* 2 n))))
|
||
(string-move! noise obscured-text 0)
|
||
(do ((i 0 (fix:+ i 1)))
|
||
((fix:= i n))
|
||
(vector-8b-set! obscured-text (fix:+ i n)
|
||
(fix:xor (vector-8b-ref clear-text i)
|
||
(vector-8b-ref noise i))))
|
||
obscured-text))))
|
||
|
||
(define (call-with-unobscured-pass-phrase obscured-text receiver)
|
||
(let ((n (quotient (string-length obscured-text) 2))
|
||
(clear-text))
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(set! clear-text (make-string n))
|
||
unspecific)
|
||
(lambda ()
|
||
(do ((i 0 (fix:+ i 1)))
|
||
((fix:= i n))
|
||
(vector-8b-set! clear-text i
|
||
(fix:xor (vector-8b-ref obscured-text i)
|
||
(vector-8b-ref obscured-text (fix:+ i n)))))
|
||
(receiver clear-text))
|
||
(lambda ()
|
||
(string-fill! clear-text #\NUL)
|
||
(set! clear-text)
|
||
unspecific))))
|