From 3e0de8592dce1b795e13311a81325e867db0e57a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 23 Jun 2008 04:04:40 +0000 Subject: [PATCH] * Now removing all duplicates by default, not only consecutive ones * Use multi-line history elements when a multi-line expression is entered svn: r10415 --- collects/readline/mzrl.ss | 42 +++- collects/readline/pread.ss | 362 ++++++++++++++++--------------- collects/readline/readline.scrbl | 29 ++- collects/readline/rep.ss | 4 +- 4 files changed, 247 insertions(+), 190 deletions(-) diff --git a/collects/readline/mzrl.ss b/collects/readline/mzrl.ss index 542f5e7f19..c5c0511b72 100644 --- a/collects/readline/mzrl.ss +++ b/collects/readline/mzrl.ss @@ -1,8 +1,9 @@ -(module mzrl mzscheme +#lang scheme/base -(require mzlib/foreign) (unsafe!) +(require mzlib/foreign (only-in '#%foreign ffi-obj)) (unsafe!) (provide readline readline-bytes add-history add-history-bytes + history-length history-get history-delete set-completion-function!) ;; libtermcap needed on some platforms @@ -42,6 +43,41 @@ (define add-history-bytes (get-ffi-obj "add_history" libreadline (_fun _bytes -> _void))) +(define history-length + (let ([hl (ffi-obj #"history_length" libreadline)]) + (lambda () (ptr-ref hl _int)))) +(define history-base + (let ([hb (ffi-obj #"history_base" libreadline)]) + (lambda () (ptr-ref hb _int)))) + +;; The history library has this great feature: *some* function consume +;; an index that is relative to history_base, and *some* get a plain +;; offset. Someone just had so much fun they had to share. This +;; deals with this absurdity, checks the range of the index, and deals +;; with negative offsets. +(define (hist-idx who idx base?) + (let* ([len (history-length)] + [idx (cond [(<= 0 idx (sub1 len)) idx] + [(<= (- len) idx -1) (+ len idx)] + [else (error who "index out of history range, -~a - ~a" + len (sub1 len))])]) + (if base? (+ idx (history-base)) idx))) + +;; actually, returns a pointer to a struct with the string, but all we +;; care about is the string... +(define history-get + (get-ffi-obj "history_get" libreadline + (_fun (i) :: (_int = (hist-idx 'history-get i #t)) -> (_ptr o _string)))) + +(define history-remove ; returns HIST_ENTRY* that history_free() frees + (get-ffi-obj "remove_history" libreadline + (_fun (i) :: (_int = (hist-idx 'history-delete i #f)) -> _pointer))) +(define history-free ; ignore histdata_t return value + (get-ffi-obj "free_history_entry" libreadline (_fun _pointer -> _void))) + +(define (history-delete idx) + (history-free (history-remove idx))) + ;; 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 @@ -81,5 +117,3 @@ ;; make it possible to run Scheme threads while waiting for input (set-ffi-obj! "rl_event_hook" libreadline (_fun -> _int) (lambda () (sync/enable-break real-input-port) 0)) - -) diff --git a/collects/readline/pread.ss b/collects/readline/pread.ss index b372f90672..5160da9ba2 100644 --- a/collects/readline/pread.ss +++ b/collects/readline/pread.ss @@ -1,201 +1,205 @@ -(module pread mzscheme - (require readline/readline mzlib/file mzlib/list mzlib/string) +#lang scheme/base - ;; -------------------------------------------------------------------------- - ;; Configuration +(require "mzrl.ss" scheme/list scheme/file) - (define current-prompt (make-parameter #"> ")) - (define show-all-prompts (make-parameter #t)) - (define max-history (make-parameter 100)) - (define keep-duplicates (make-parameter #f)) - (define keep-blanks (make-parameter #f)) - (provide current-prompt show-all-prompts - max-history keep-duplicates keep-blanks) +;; -------------------------------------------------------------------------- +;; Configuration - ;; -------------------------------------------------------------------------- - ;; Simple namespace-based completion +(define current-prompt (make-parameter #"> ")) +(define max-history (make-parameter 100)) +(define keep-duplicates (make-parameter #f)) +(define keep-blanks (make-parameter #f)) +(provide current-prompt max-history keep-duplicates keep-blanks) - ;; 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))))) +;; -------------------------------------------------------------------------- +;; Simple namespace-based completion - ;; 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) bytesbstring + (let ([t (make-weak-hash)]) + (lambda (sym) + (or (hash-ref t sym #f) + (let ([bstr (string->bytes/utf-8 (symbol->string sym))]) + (hash-set! t sym bstr) + bstr))))) - (define (namespace-completion pat) - (let* ([pat (if (string? pat) (string->bytes/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)))) +;; 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 +;; -------------------------------------------------------------------------- +;; History management +;; (Note: local-history, and the preference are in reverse order, from +;; the newest to the oldest.) - (define local-history - (let ([hist (get-preference 'readline-input-history (lambda () null))]) - (for-each add-history hist) - (reverse hist))) +(define local-history '()) - (define (save-history) - (put-preferences '(readline-input-history) (list (reverse local-history)))) +(define (trim-local-history) + (when ((length local-history) . > . (max-history)) + (set! local-history (take local-history (max-history))))) - ;; captured now so we don't flush some other output port - (define readline-output-port (current-output-port)) +(define (load-history) + (set! local-history (get-preference 'readline-input-history (lambda () null))) + (trim-local-history) + (for-each add-history (reverse local-history))) +;; add it now to the actual history +(load-history) - (define (readline-bytes/hist p) - (when (eq? readline-output-port (current-output-port)) - (let-values ([(line col pos) (port-next-location readline-output-port)]) - (when (and col (< 0 col)) (newline)))) - (let ([s (readline-bytes p)]) - (when (and (bytes? s) - (or (keep-blanks) (not (zero? (bytes-length s)))) - (or (keep-duplicates) - (null? local-history) - (not (equal? s (car local-history))))) - (add-history-bytes s) - (set! local-history (cons s local-history)) - (set! local-history - (let loop ([n (max-history)] [l local-history]) - (cond [(null? l) null] - [(zero? n) null] - [else (let ([p (loop (sub1 n) (cdr l))]) - (if (eq? p (cdr l)) - l - (cons (car l) p)))])))) - s)) +(define (save-history) + (put-preferences '(readline-input-history) (list local-history))) - (exit-handler - (let ([old (exit-handler)]) - (lambda (v) (save-history) (old v)))) +(define (add-to-history s force-keep?) + (define keep (or force-keep? (keep-duplicates))) + (when (and (bytes? s) (or (keep-blanks) (not (zero? (bytes-length s))))) + ;; remove duplicate (keep-blanks determines how we search) + (unless (or (null? local-history) (eq? #t keep)) + (let ([dup (let loop ([n -1] [h local-history] [r '()]) + (cond [(null? h) #f] + [(equal? (car h) s) `(,n ,@(reverse r) ,@(cdr h))] + [(eq? keep 'unconsecutive) #f] ; no loop + [else (loop (sub1 n) (cdr h) (cons (car h) r))]))]) + (when dup + (set! local-history (cdr dup)) + (history-delete (car dup))))) + (add-history-bytes s) + (let loop () + (when (< (max-history) (history-length)) (history-delete 0) (loop))) + (set! local-history (cons s local-history)) + (trim-local-history))) - ;; -------------------------------------------------------------------------- - ;; An input port that goes through readline +(define (drop-history n) + (for ([i (in-range n)]) (history-delete -1)) + (set! local-history (drop local-history n))) - ;; readline-prompt can be - ;; #f: no prompt (normal state), - ;; bytes: a prompt to use - ;; 'space: a port has been used, now use spaces instead - ;; (from readline-prompt-spaces) - (provide readline-prompt) - (define readline-prompt (make-parameter #f)) - (define readline-prompt-spaces (make-parameter #" ")) +;; captured now so we don't flush some other output port +(define readline-output-port (current-output-port)) +(port-count-lines! readline-output-port) - (define (get-current-prompt) - (let ([p (readline-prompt)]) - (case p - [(#f) #""] - [(space) (readline-prompt-spaces)] - [else (unless (= (bytes-length (readline-prompt-spaces)) - (bytes-length p)) - (readline-prompt-spaces (make-bytes (bytes-length p) 32))) - (readline-prompt 'space) ; use spaces next time - p]))) +(define (readline-bytes/hist p force-keep?) + (when (eq? readline-output-port (current-output-port)) + (let-values ([(line col pos) (port-next-location readline-output-port)]) + (when (< 0 col) (newline readline-output-port)))) + (let ([s (readline-bytes p)]) (add-to-history s force-keep?) s)) - (provide readline-input) - (define readline-input - (let ([buffer #f] - [skip #f] - [blen #f] - [closed? #f] - [LF (bytes-ref #"\n" 0)]) - (define (close!) (set! closed? #t) (save-history)) - (define (reader tgt) - (let loop () - (cond [closed? eof] - [(eof-object? buffer) (set! buffer #f) eof] - [(not buffer) - (set! buffer (readline-bytes/hist (get-current-prompt))) - (if (eof-object? buffer) - (begin (save-history) (set! buffer #f) eof) - (begin (set! skip 0) - (set! blen (bytes-length buffer)) - (reader tgt)))] - [else - ;; copy bytes - (let ([tgtlen (bytes-length tgt)] - [left (- blen skip)]) - (cond [(< tgtlen left) ; not enough target space - (let ([end (+ skip tgtlen)]) - (bytes-copy! tgt 0 buffer skip end) - (set! skip end) - tgtlen)] - [(= tgtlen left) ; enough room for text but no newline - (bytes-copy! tgt 0 buffer skip blen) - (set! skip blen) - left] - [else ; enough room for text with newline - (bytes-copy! tgt 0 buffer skip blen) - (bytes-set! tgt left LF) - (set! buffer #f) - (add1 left)]))]))) - (make-input-port 'readline reader #f close!))) +(exit-handler + (let ([old (exit-handler)]) + (lambda (v) (save-history) (old v)))) - ;; -------------------------------------------------------------------------- - ;; Reading functions +;; -------------------------------------------------------------------------- +;; An input port that goes through readline - ;; like read-syntax, but waits until valid input is ready - (define read-complete-syntax - (let ([leftovers '()] - [counter 1]) - (lambda () - (if (pair? leftovers) - (begin0 (car leftovers) - (set! leftovers (cdr leftovers))) - (let big-loop () - (let loop ([s (read-line)] [next-pos 1] [force? #f]) - (if (eof-object? s) - (begin (save-history) s) - (with-handlers ([(if force? (lambda (x) #f) exn:fail:read:eof?) - (lambda (exn) - (let ([v (read-line)]) - (loop (string-append - s "\n" (if (eof-object? v) "" v)) - (add1 next-pos) - (eof-object? v))))]) - (let ([p (open-input-string (string-append s "\n"))]) - (port-count-lines! p) - (let ([rs (let loop () - (let ([r (read-syntax - (string->symbol - (format "repl-~a" counter)) - p)]) - (if (eof-object? r) '() (cons r (loop)))))]) - (if (null? rs) - (big-loop) - (begin0 (car rs) - (set! counter (add1 counter)) - (set! leftovers (cdr rs)))))))))))))) +;; readline-prompt can be +;; #f: no prompt (normal state), +;; : a prompt to use +;; 'space: a prompt has been used, now use spaces instead +;; (from readline-prompt-spaces) +;; this also controls saving multi-line histories: when the prompt is #f we +;; collect history as usual; otherwise, we accumulate the lines in a chunk (and +;; add them to the history without removing duplicates) and at the beginning of +;; each new chunk (when we read a line with a prompt that is not 'space) we +;; throw away the intermediate history lines that were added and add the whole +;; chunk as one big multiline string. +(provide readline-prompt) +(define readline-prompt (make-parameter #f)) +(define readline-prompt-spaces (make-parameter #" ")) +(define multiline-chunk (make-parameter '())) - ;; a function that can be used for current-prompt-read - (provide read-cmdline-syntax) - (define (read-cmdline-syntax) - (define prompt (current-prompt)) - (flush-output) - ;; needs to set `readline-prompt' to get a prompt when reading - (parameterize ([read-accept-reader #t] - [readline-prompt prompt]) - (unless (eq? readline-input (current-input-port)) - ;; not the readline port -- print the prompt (changing the - ;; readline-prompt and using read-complete-syntax below should still - ;; work fine) - (display prompt) (flush-output)) - (if (show-all-prompts) (read-syntax) (read-complete-syntax)))) +(define (do-multiline-chunk) + (let ([chunk (multiline-chunk)]) + (when (pair? chunk) + (drop-history (length chunk)) + (add-to-history (apply bytes-append (reverse chunk)) #f) + (multiline-chunk '())))) - ) +(define (readline-bytes/multiline-chunk prompt) + (let ([line (readline-bytes/hist prompt #t)]) + (when (and (bytes? line) (not (zero? (bytes-length line)))) + (let ([c (multiline-chunk)]) + (multiline-chunk (if (pair? c) + (list* line (readline-prompt-spaces) #"\n" c) + (cons line c))))) + line)) + +(define (do-one-line) + (let ([p (readline-prompt)]) + (case p + [(#f) (do-multiline-chunk) (readline-bytes/hist #"" #f)] + [(space) (readline-bytes/multiline-chunk (readline-prompt-spaces))] + [else (do-multiline-chunk) + (unless (= (bytes-length (readline-prompt-spaces)) + (bytes-length p)) + (readline-prompt-spaces (make-bytes (bytes-length p) 32))) + (readline-prompt 'space) ; use spaces next time + (readline-bytes/multiline-chunk p)]))) + +(provide readline-input) +(define readline-input + (let ([buffer #f] + [skip #f] + [blen #f] + [closed? #f] + [LF (bytes-ref #"\n" 0)]) + (define (close!) (set! closed? #t) (save-history)) + (define (reader tgt) + (let loop () + (cond [closed? eof] + [(eof-object? buffer) (set! buffer #f) eof] + [(not buffer) + (set! buffer (do-one-line)) + (if (eof-object? buffer) + (begin (save-history) (set! buffer #f) eof) + (begin (set! skip 0) + (set! blen (bytes-length buffer)) + (reader tgt)))] + [else + ;; copy bytes + (let ([tgtlen (bytes-length tgt)] + [left (- blen skip)]) + (cond [(< tgtlen left) ; not enough target space + (let ([end (+ skip tgtlen)]) + (bytes-copy! tgt 0 buffer skip end) + (set! skip end) + tgtlen)] + [(= tgtlen left) ; enough room for text but no newline + (bytes-copy! tgt 0 buffer skip blen) + (set! skip blen) + left] + [else ; enough room for text with newline + (bytes-copy! tgt 0 buffer skip blen) + (bytes-set! tgt left LF) + (set! buffer #f) + (add1 left)]))]))) + (make-input-port 'readline reader #f close!))) + +;; -------------------------------------------------------------------------- +;; Reading functions + +;; a function that can be used for current-prompt-read +(provide read-cmdline-syntax) +(define (read-cmdline-syntax) + (define prompt (current-prompt)) + (flush-output) + ;; needs to set `readline-prompt' to get a prompt when reading + (parameterize ([read-accept-reader #t] [readline-prompt prompt]) + (unless (eq? readline-input (current-input-port)) + ;; not the readline port -- print the prompt (changing the + ;; readline-prompt and using read-complete-syntax below should still + ;; work fine) + (display prompt) (flush-output)) + (begin0 (read-syntax) (do-multiline-chunk)))) diff --git a/collects/readline/readline.scrbl b/collects/readline/readline.scrbl index fa87108a22..8e6c26e51c 100644 --- a/collects/readline/readline.scrbl +++ b/collects/readline/readline.scrbl @@ -116,10 +116,13 @@ A parameter that determines the number of history entries to save, defaults to @scheme[100].} -@defboolparam[keep-duplicates keep?]{ +@defparam[keep-duplicates keep? (one-of/c #f 'unconsecutive #t)]{ -A parameter. If @scheme[#f] (the default), then lines that are equal -to the previous one are not added as new history items.} +A parameter. If @scheme[#f] (the default), then when a line is equal +to a previous one, the previous one is removed. If it set to +@scheme['unconsecutive] then this happens only for an line that +duplicates the previous one, and if it is @scheme[#f] then all +duplicates are kept.} @defboolparam[keep-blanks keep?]{ @@ -186,11 +189,29 @@ Adds the given string to the @|readline| history, which is accessible to the user via the up-arrow key.} -@defproc[(add-history-bytes [str string?]) void?]{ +@defproc[(add-history-bytes [str bytes?]) void?]{ Adds the given byte string to the @|readline| history, which is accessible to the user via the up-arrow key.} +@defproc[(history-length) nonnegative-exact-integer?]{ + +Returns the length of the history list.} + + +@defproc[(history-get [idx integer?]) string?]{ + +Returns the history string at the @scheme[idx] position. @scheme[idx] +can be negative, which will make it count from the last (i.e, +@scheme[-1] returns the last item, @scheme[-2] returns the +second-to-last, etc.)} + + +@defproc[(history-delete [idx integer?]) string?]{ + +Deletes the history string at the @scheme[idx] position. The position +is specified in the same way as the argument for @scheme[history-get].} + @defproc[(set-completion-function! [proc ((or/c string? bytes?) . -> . (listof (or/c string? bytes?)))] diff --git a/collects/readline/rep.ss b/collects/readline/rep.ss index ef74b36d51..52707c6e6a 100644 --- a/collects/readline/rep.ss +++ b/collects/readline/rep.ss @@ -9,9 +9,7 @@ (let ([inp (current-input-port)] [outp (current-output-port)]) (when (and (eq? 'stdin (object-name inp)) (terminal-port? inp)) - (dynamic-require rep-start #f) - (when (terminal-port? outp) - (port-count-lines! outp)))) + (dynamic-require rep-start #f))) (define readline-init-expr '(require readline/rep))