diff --git a/collects/readline/mzrl.ss b/collects/readline/mzrl.ss index 8462bbe566..1b09ace2e3 100644 --- a/collects/readline/mzrl.ss +++ b/collects/readline/mzrl.ss @@ -5,7 +5,7 @@ add-history add-history-bytes set-completion-function!) -;; libtermcap maybe needed +;; libtermcap needed on some platforms (define libtermcap (with-handlers ([exn:fail? void]) (ffi-lib "libtermcap"))) (define libreadline (ffi-lib "libreadline")) @@ -42,25 +42,29 @@ (define add-history-bytes (get-ffi-obj "add_history" libreadline (_fun _bytes -> _void))) -;; Simple completion: use this with a (string -> list-of string) function that -;; returns the completions for a given string. (should clean up bytes/string) +;; Simple completion: use this with a (string -> (list-of string)) function +;; that returns the completions for a given string (can be used with other +;; input string types too, depending on the `type' argument). Use #f to remove +;; a completion function that was previously set. (define set-completion-function! (case-lambda - [(func) (set-completion-function! _string)] + [(func) (set-completion-function! func _string)] [(func type) (if func (set-ffi-obj! "rl_completion_entry_function" libreadline (_fun type _int -> _pointer) (completion-function func)) (set-ffi-obj! "rl_completion_entry_function" libreadline _pointer #f))])) + (define (completion-function func) (let ([cur '()]) (define (complete str state) (if (zero? state) - (begin (set! cur (func str)) (complete str 1)) + (begin (set! cur (func str)) (complete #f 1)) (and (pair? cur) - (begin0 (malloc (add1 (bytes-length (car cur))) (car cur) 'raw) - (set! cur (cdr cur)))))) + (let* ([cur (begin0 (car cur) (set! cur (cdr cur)))] + [cur (if (string? cur) (string->bytes/utf-8 cur) cur)]) + (malloc (add1 (bytes-length cur)) cur 'raw))))) complete)) (set-ffi-obj! "rl_readline_name" libreadline _bytes #"mzscheme") diff --git a/collects/readline/pread.ss b/collects/readline/pread.ss index 3ae48e6162..0d43d8543b 100644 --- a/collects/readline/pread.ss +++ b/collects/readline/pread.ss @@ -1,7 +1,10 @@ (module pread mzscheme - (require (lib "readline.ss" "readline") (lib "file.ss")) + (require (lib "readline.ss" "readline") (lib "file.ss") + (lib "list.ss") (lib "string.ss")) + + ;; -------------------------------------------------------------------------- + ;; Configuration - ;; configuration (define current-prompt (make-parameter #"> ")) (define show-all-prompts (make-parameter #t)) (define max-history (make-parameter 100)) @@ -10,6 +13,40 @@ (provide current-prompt show-all-prompts max-history keep-duplicates keep-blanks) + ;; -------------------------------------------------------------------------- + ;; Simple namespace-based completion + + ;; efficiently convert symbols to byte strings + (define symbol->bstring + (let ([t (make-hash-table 'weak)]) + (lambda (sym) + (or (hash-table-get t sym #f) + (let ([bstr (string->bytes/utf-8 (symbol->string sym))]) + (hash-table-put! t sym bstr) + bstr))))) + + ;; get a list of byte strings for current bindings, cache last result + (define get-namespace-bstrings + (let ([last-syms #f] [last-bstrs #f]) + (lambda () + (let ([syms (namespace-mapped-symbols)]) + (unless (equal? syms last-syms) + (set! last-syms syms) + (set! last-bstrs (sort! (map symbol->bstring syms) bytesbytes/utf-8 pat) pat)] + [pat (regexp-quote pat)] + [pat (regexp-replace* #px#"(\\w)\\b" pat #"\\1\\\\w*")] + [pat (byte-pregexp (bytes-append #"^" pat))]) + (filter (lambda (bstr) (regexp-match pat bstr)) + (get-namespace-bstrings)))) + + (set-completion-function! namespace-completion) + + + ;; -------------------------------------------------------------------------- ;; History management (define local-history @@ -45,7 +82,8 @@ (let ([old (exit-handler)]) (lambda (v) (save-history) (old v)))) - ;; implement an input port that goes through readline + ;; -------------------------------------------------------------------------- + ;; An input port that goes through readline ;; readline-prompt can be ;; #f: no prompt (normal state), @@ -106,6 +144,9 @@ (add1 left)]))]))) (make-input-port 'readline reader #f close!))) + ;; -------------------------------------------------------------------------- + ;; Reading functions + ;; like read-syntax, but waits until valid input is ready (define read-complete-syntax (let ([leftovers '()]