-
-
Notifications
You must be signed in to change notification settings - Fork 9
/
pread.rkt
242 lines (214 loc) · 9.14 KB
/
pread.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
#lang racket/base
(require "rktrl.rkt" racket/list racket/file)
;; --------------------------------------------------------------------------
;; Configuration
(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)
;; --------------------------------------------------------------------------
;; Simple namespace-based completion
;; 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)))))
;; get a list of byte strings for current bindings, cache last result
(define get-namespace-bstrings
(let ([last-syms #f] [last-bstrs #f])
(lambda ()
(define syms (namespace-mapped-symbols))
(unless (equal? syms last-syms)
(set! last-syms syms)
(set! last-bstrs (sort (map symbol->bstring syms) bytes<?)))
last-bstrs)))
(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
;; (Note: local-history, and the preference are in reverse order, from
;; the newest to the oldest.)
(define local-history '())
(define (trim-local-history)
(when ((length local-history) . > . (max-history))
(set! local-history (take local-history (max-history)))))
(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 (save-history)
(put-preferences '(readline-input-history) (list local-history)))
(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))
(define 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 ((history-length) . > . (max-history)) (history-delete 0) (loop)))
(set! local-history (cons s local-history))
(trim-local-history)))
;; remove `l' items from `local-history', ignoring ones that are not
;; in the front of the history (in the eq? sense)
(define (drop-from-history l)
(let loop ([l l] [h local-history])
(if (and (pair? l) (pair? h))
(if (eq? (car l) (car h))
(begin (history-delete -1) (loop (cdr l) (cdr h)))
(loop (cdr l) h))
(set! local-history h))))
;; 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 (readline-bytes/hist p force-keep?)
(when (eq? readline-output-port (current-output-port))
(define-values [line col pos] (port-next-location readline-output-port))
(when (and col (positive? col)) (newline readline-output-port)))
(let ([s (readline-bytes (bytes-append p #"\0"))]) (add-to-history s force-keep?) s))
(exit-handler
(let ([old (exit-handler)])
(lambda (v) (save-history) (old v))))
;; --------------------------------------------------------------------------
;; An input port that goes through readline
;; 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-struct readline-state (prompt-spaces multiline-chunk)
#:mutable)
(define readline-state-cell (make-thread-cell #f))
(define (get-readline-state)
(or (thread-cell-ref readline-state-cell)
(let ([state (readline-state #" " '())])
(thread-cell-set! readline-state-cell state)
state)))
(define (do-multiline-chunk state)
(define chunk (readline-state-multiline-chunk state))
(when (pair? chunk)
(drop-from-history chunk)
(add-to-history (apply bytes-append (reverse chunk)) #f)
(set-readline-state-multiline-chunk! state '())))
(define (readline-bytes/multiline-chunk prompt state)
(define line (readline-bytes/hist prompt #t))
(when (and (bytes? line) (not (zero? (bytes-length line))))
(define c (readline-state-multiline-chunk state))
(set-readline-state-multiline-chunk!
state
(if (pair? c)
(list* line (readline-state-prompt-spaces state) #"\n" c)
(cons line c))))
line)
(define (do-one-line state k)
(define p (readline-prompt))
(case p
[(#f) (thread (lambda ()
(do-multiline-chunk state)
(k (readline-bytes/hist #"" #f))))]
[(space) (thread
(lambda ()
(k (readline-bytes/multiline-chunk
(readline-state-prompt-spaces state)
state))))]
[else (readline-prompt 'space) ; use spaces next time
(thread
(lambda ()
(do-multiline-chunk state)
(unless (= (bytes-length (readline-state-prompt-spaces state))
(bytes-length p))
(set-readline-state-prompt-spaces!
state
(make-bytes (bytes-length p) 32)))
(k (readline-bytes/multiline-chunk p state))))]))
(provide readline-input)
(define readline-input
(let ([buffer #f]
[evt #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]
[evt evt]
[(not buffer)
(set! evt
(wrap-evt
(do-one-line
(get-readline-state)
(lambda (buf)
(if (eof-object? buf)
(save-history)
(begin (set! skip 0)
(set! blen (bytes-length buf))))
(set! buffer buf)
(set! evt #f)))
(lambda (v) 0)))
evt]
[else
;; copy bytes
(define tgtlen (bytes-length tgt))
(define 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-input 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 ([readline-prompt prompt])
(define in ((current-get-interaction-input-port)))
(unless (eq? 'readline-input (object-name in))
;; 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 ((current-read-interaction) (object-name in) in)
(do-multiline-chunk (get-readline-state)))))