suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Racketizations.

Browse Source
This commit is contained in:
Eli Barzilay 2012-05-06 13:13:10 -04:00
parent 17090fca4f
commit 49c8a5fb28
1 changed files with 77 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

155
collects/readline/pread.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require "mzrl.rkt" scheme/list scheme/file) (require "mzrl.rkt" racket/list racket/file)
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Configuration ;; Configuration
@ -27,11 +27,11 @@
(define get-namespace-bstrings (define get-namespace-bstrings
(let ([last-syms #f] [last-bstrs #f]) (let ([last-syms #f] [last-bstrs #f])
(lambda () (lambda ()
(let ([syms (namespace-mapped-symbols)]) (define syms (namespace-mapped-symbols))
(unless (equal? syms last-syms) (unless (equal? syms last-syms)
(set! last-syms syms) (set! last-syms syms)
(set! last-bstrs (sort (map symbol->bstring syms) bytes<?))) (set! last-bstrs (sort (map symbol->bstring syms) bytes<?)))
last-bstrs)))) last-bstrs)))
(define (namespace-completion pat) (define (namespace-completion pat)
(let* ([pat (if (string? pat) (string->bytes/utf-8 pat) pat)] (let* ([pat (if (string? pat) (string->bytes/utf-8 pat) pat)]
@ -69,14 +69,14 @@
(when (and (bytes? s) (or (keep-blanks) (not (zero? (bytes-length s))))) (when (and (bytes? s) (or (keep-blanks) (not (zero? (bytes-length s)))))
;; remove duplicate (keep-blanks determines how we search) ;; remove duplicate (keep-blanks determines how we search)
(unless (or (null? local-history) (eq? #t keep)) (unless (or (null? local-history) (eq? #t keep))
(let ([dup (let loop ([n -1] [h local-history] [r '()]) (define dup (let loop ([n -1] [h local-history] [r '()])
(cond [(null? h) #f] (cond [(null? h) #f]
[(equal? (car h) s) `(,n ,@(reverse r) ,@(cdr h))] [(equal? (car h) s) `(,n ,@(reverse r) ,@(cdr h))]
[(eq? keep 'unconsecutive) #f] ; no loop [(eq? keep 'unconsecutive) #f] ; no loop
[else (loop (sub1 n) (cdr h) (cons (car h) r))]))]) [else (loop (sub1 n) (cdr h) (cons (car h) r))])))
(when dup (when dup
(set! local-history (cdr dup)) (set! local-history (cdr dup))
(history-delete (car dup))))) (history-delete (car dup))))
(add-history-bytes s) (add-history-bytes s)
(let loop () (let loop ()
(when ((history-length) . > . (max-history)) (history-delete 0) (loop))) (when ((history-length) . > . (max-history)) (history-delete 0) (loop)))
@ -99,8 +99,8 @@
(define (readline-bytes/hist p force-keep?) (define (readline-bytes/hist p force-keep?)
(when (eq? readline-output-port (current-output-port)) (when (eq? readline-output-port (current-output-port))
(let-values ([(line col pos) (port-next-location readline-output-port)]) (define-values [line col pos] (port-next-location readline-output-port))
(when (and col (positive? col)) (newline readline-output-port)))) (when (and col (positive? col)) (newline readline-output-port)))
(let ([s (readline-bytes p)]) (add-to-history s force-keep?) s)) (let ([s (readline-bytes p)]) (add-to-history s force-keep?) s))
(exit-handler (exit-handler
@ -135,43 +135,44 @@
state))) state)))
(define (do-multiline-chunk state) (define (do-multiline-chunk state)
(let ([chunk (readline-state-multiline-chunk state)]) (define chunk (readline-state-multiline-chunk state))
(when (pair? chunk) (when (pair? chunk)
(drop-from-history chunk) (drop-from-history chunk)
(add-to-history (apply bytes-append (reverse chunk)) #f) (add-to-history (apply bytes-append (reverse chunk)) #f)
(set-readline-state-multiline-chunk! state '())))) (set-readline-state-multiline-chunk! state '())))
(define (readline-bytes/multiline-chunk prompt state) (define (readline-bytes/multiline-chunk prompt state)
(let ([line (readline-bytes/hist prompt #t)]) (define line (readline-bytes/hist prompt #t))
(when (and (bytes? line) (not (zero? (bytes-length line)))) (when (and (bytes? line) (not (zero? (bytes-length line))))
(let ([c (readline-state-multiline-chunk state)]) (define c (readline-state-multiline-chunk state))
(set-readline-state-multiline-chunk! (set-readline-state-multiline-chunk!
state state
(if (pair? c) (if (pair? c)
(list* line (readline-state-prompt-spaces state) #"\n" c) (list* line (readline-state-prompt-spaces state) #"\n" c)
(cons line c))))) (cons line c))))
line)) line)
(define (do-one-line state k) (define (do-one-line state k)
(let ([p (readline-prompt)]) (define p (readline-prompt))
(case p (case p
[(#f) (thread (lambda () [(#f) (thread (lambda ()
(do-multiline-chunk state) (do-multiline-chunk state)
(k (readline-bytes/hist #"" #f))))] (k (readline-bytes/hist #"" #f))))]
[(space) (thread [(space) (thread
(lambda () (lambda ()
(k (readline-bytes/multiline-chunk (readline-state-prompt-spaces state) (k (readline-bytes/multiline-chunk
state))))] (readline-state-prompt-spaces state)
[else (readline-prompt 'space) ; use spaces next time state))))]
(thread [else (readline-prompt 'space) ; use spaces next time
(lambda () (thread
(do-multiline-chunk state) (lambda ()
(unless (= (bytes-length (readline-state-prompt-spaces state)) (do-multiline-chunk state)
(bytes-length p)) (unless (= (bytes-length (readline-state-prompt-spaces state))
(set-readline-state-prompt-spaces! (bytes-length p))
state (set-readline-state-prompt-spaces!
(make-bytes (bytes-length p) 32))) state
(k (readline-bytes/multiline-chunk p state))))]))) (make-bytes (bytes-length p) 32)))
(k (readline-bytes/multiline-chunk p state))))]))
(provide readline-input) (provide readline-input)
(define readline-input (define readline-input
@ -195,31 +196,30 @@
(lambda (buf) (lambda (buf)
(if (eof-object? buf) (if (eof-object? buf)
(save-history) (save-history)
(begin (begin (set! skip 0)
(set! skip 0) (set! blen (bytes-length buf))))
(set! blen (bytes-length buf))))
(set! buffer buf) (set! buffer buf)
(set! evt #f))) (set! evt #f)))
(lambda (v) 0))) (lambda (v) 0)))
evt] evt]
[else [else
;; copy bytes ;; copy bytes
(let ([tgtlen (bytes-length tgt)] (define tgtlen (bytes-length tgt))
[left (- blen skip)]) (define left (- blen skip))
(cond [(< tgtlen left) ; not enough target space (cond [(< tgtlen left) ; not enough target space
(let ([end (+ skip tgtlen)]) (let ([end (+ skip tgtlen)])
(bytes-copy! tgt 0 buffer skip end) (bytes-copy! tgt 0 buffer skip end)
(set! skip end) (set! skip end)
tgtlen)] tgtlen)]
[(= tgtlen left) ; enough room for text but no newline [(= tgtlen left) ; enough room for text but no newline
(bytes-copy! tgt 0 buffer skip blen) (bytes-copy! tgt 0 buffer skip blen)
(set! skip blen) (set! skip blen)
left] left]
[else ; enough room for text with newline [else ; enough room for text with newline
(bytes-copy! tgt 0 buffer skip blen) (bytes-copy! tgt 0 buffer skip blen)
(bytes-set! tgt left LF) (bytes-set! tgt left LF)
(set! buffer #f) (set! buffer #f)
(add1 left)]))]))) (add1 left)])])))
(make-input-port 'readline-input reader #f close!))) (make-input-port 'readline-input reader #f close!)))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
@ -232,12 +232,11 @@
(flush-output) (flush-output)
;; needs to set `readline-prompt' to get a prompt when reading ;; needs to set `readline-prompt' to get a prompt when reading
(parameterize ([readline-prompt prompt]) (parameterize ([readline-prompt prompt])
(let ([in ((current-get-interaction-input-port))]) (define in ((current-get-interaction-input-port)))
(unless (eq? 'readline-input (object-name in)) (unless (eq? 'readline-input (object-name in))
;; not the readline port -- print the prompt (changing the ;; not the readline port -- print the prompt (changing the
;; readline-prompt and using read-complete-syntax below should still ;; readline-prompt and using read-complete-syntax below should still
;; work fine) ;; work fine)
(display prompt) (flush-output)) (display prompt) (flush-output))
(begin0 ((current-read-interaction) (object-name in) in) (begin0 ((current-read-interaction) (object-name in) in)
(do-multiline-chunk (get-readline-state)))))) (do-multiline-chunk (get-readline-state)))))