* Now removing all duplicates by default, not only consecutive ones
* Use multi-line history elements when a multi-line expression is entered svn: r10415
This commit is contained in:
Eli Barzilay
parent
4ca2fb8c00
commit
3e0de8592d
|
|
@ -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))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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) bytes<?)))
|
||||
last-bstrs))))
|
||||
;; efficiently convert symbols to byte strings
|
||||
(define symbol->bstring
|
||||
(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) bytes<?)))
|
||||
last-bstrs))))
|
||||
|
||||
(set-completion-function! namespace-completion)
|
||||
(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))))
|
||||
|
||||
(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),
|
||||
;; <bytes>: 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))))
|
||||
|
|
|
|||
|
|
@ -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?)))]
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user