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

Some reformating. The only real change is using `write-bytes' instead

Browse Source 
of a `display' in one place.
This commit is contained in:
Eli Barzilay 2011-06-04 16:32:36 -04:00
parent 3ecdd3bc59
commit 5754312120
1 changed files with 285 additions and 281 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

554
collects/racket/private/string.rkt
View File

@ -15,22 +15,21 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (real->decimal-string n [digits 2])
(unless (exact-nonnegative-integer? digits)
(raise-type-error 'real->decimal-string "exact-nonnegative-integer" digits))
(raise-type-error 'real->decimal-string "exact-nonnegative-integer"
digits))
(let* ([e (expt 10 digits)]
[num (round (abs (* e (inexact->exact n))))])
(format "~a~a.~a"
(if (or (negative? n)
(equal? n -0.0))
"-"
"")
(quotient num e)
(if (zero? digits)
""
(let ([s (number->string (remainder num e))])
(if (= (string-length s) digits)
s
(string-append (make-string (- digits (string-length s)) #\0)
s)))))))
(format
"~a~a.~a"
(if (or (negative? n) (equal? n -0.0)) "-" "")
(quotient num e)
(if (zero? digits)
""
(let ([s (number->string (remainder num e))])
(if (= (string-length s) digits)
s
(string-append (make-string (- digits (string-length s)) #\0)
s)))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Regexp utilities
@ -87,39 +86,38 @@
(or (hash-ref t key #f)
(let ([rx* (run-tweak)]) (hash-set! t key rx*) rx*))))))
(define (regexp-try-match pattern input-port [start-k 0] [end-k #f] [out #f] [prefix #""])
(define (regexp-try-match pattern input-port [start-k 0] [end-k #f] [out #f]
[prefix #""])
(unless (input-port? input-port)
(raise-type-error 'regexp-try-match
"input port" input-port))
(raise-type-error 'regexp-try-match "input port" input-port))
(unless (or (not out) (output-port? out))
(raise-type-error 'regexp-try-match
"output port or #f" out))
(let ([m (regexp-match-peek-positions pattern input-port start-k end-k #f prefix)])
(raise-type-error 'regexp-try-match "output port or #f" out))
(let ([m (regexp-match-peek-positions pattern input-port start-k end-k #f
prefix)])
(and m
;; What happens if someone swipes our bytes before we can get them?
(let ([drop (caar m)])
;; drop prefix before match:
(let ([s (read-bytes drop input-port)])
(when out
(display s out)))
(when out (write-bytes s out)))
;; Get the matching part, and shift matching indices
(let ([s (read-bytes (- (cdar m) drop) input-port)])
(cons s
(map (lambda (p)
(and p (subbytes s (- (car p) drop) (- (cdr p) drop))))
(and p (subbytes s (- (car p) drop)
(- (cdr p) drop))))
(cdr m))))))))
;; Helper macro for the regexp functions below, with some utilities.
(define (bstring-length s)
(if (bytes? s) (bytes-length s) (string-length s)))
(define no-empty-edge-matches
(make-regexp-tweaker (lambda (rx n)
(if (bytes? rx)
(bytes-append #"(?:"
rx
#")(?<=" (make-bytes n (char->integer #\.)) #")")
(format "(?:~a)(?<=~a)"
rx (make-bytes n (char->integer #\.)))))))
(make-regexp-tweaker
(lambda (rx n)
(if (bytes? rx)
(bytes-append #"(?:" rx #")(?<="
(make-bytes n (char->integer #\.)) #")")
(format "(?:~a)(?<=~a)" rx (make-bytes n (char->integer #\.)))))))
(define-syntax-rule (regexp-loop
name loop start end pattern string
ipre
@ -127,21 +125,22 @@
port-success-k port-success-choose port-failure-k
need-leftover? peek?)
(let* ([string (if (path? string)
(if (or (string? pattern) (regexp? pattern))
(path->string string)
(path->bytes string))
string)]
(if (or (string? pattern) (regexp? pattern))
(path->string string)
(path->bytes string))
string)]
[len (cond [(string? string) (string-length string)]
[(bytes? string) (bytes-length string)]
[else #f])]
[orig-rx (cond [(bytes? pattern) (byte-regexp pattern)]
[(string? pattern) (regexp pattern)]
[(regexp? pattern) pattern]
[(byte-regexp? pattern) pattern]
[else
(raise-type-error 'name
"regexp, byte regexp, string, or byte string"
pattern)])]
[orig-rx
(cond [(bytes? pattern) (byte-regexp pattern)]
[(string? pattern) (regexp pattern)]
[(regexp? pattern) pattern]
[(byte-regexp? pattern) pattern]
[else (raise-type-error
'name
"regexp, byte regexp, string, or byte string"
pattern)])]
[max-lookbehind (regexp-max-lookbehind orig-rx)])
(if peek?
(unless (input-port? string)
@ -172,279 +171,284 @@
end))
(reverse
(let loop ([acc '()] [start start] [end end] [ipre ipre] [0-ok? #t])
(let* ([rx (if 0-ok?
orig-rx
(no-empty-edge-matches orig-rx (add1 (bytes-length ipre))))])
(let ([rx (if 0-ok?
orig-rx
(no-empty-edge-matches orig-rx
(add1 (bytes-length ipre))))])
(if (and port-success-choose (input-port? string))
;; Input port match, get string
(let* ([_ (when (positive? start)
;; Skip start chars:
(let ([s (make-bytes 4096)])
(let loop ([n 0])
(unless (= n start)
(let ([m (read-bytes-avail!
s string 0 (min (- start n) 4096))])
(unless (eof-object? m) (loop (+ n m))))))))]
[discarded/leftovers (if need-leftover? #f 0)]
[spitout (if need-leftover?
(open-output-bytes)
(make-output-port
'counter always-evt
(lambda (s start end flush? breakable?)
(let ([c (- end start)])
(set! discarded/leftovers
(+ c discarded/leftovers))
c))
void))]
[end (and end (- end start))])
(let-values ([(ms ipre) (regexp-match/end rx
string 0 end spitout ipre
max-lookbehind)])
(let* ([m (and ms (car ms))]
[discarded/leftovers (if need-leftover?
(get-output-bytes spitout)
discarded/leftovers)]
[skipped (if need-leftover?
(bstring-length discarded/leftovers)
discarded/leftovers)]
[got (and m (bstring-length m))]
[end (and end m
(- end skipped got))])
(if m
(let ([0-ok? (not (zero? got))])
(loop (port-success-choose m discarded/leftovers ms acc)
0 end ipre 0-ok?))
(port-failure-k acc discarded/leftovers)))))
;; Input port match, get string
(let* ([_ (when (positive? start)
;; Skip start chars:
(let ([s (make-bytes 4096)])
(let loop ([n 0])
(unless (= n start)
(let ([m (read-bytes-avail!
s string 0 (min (- start n) 4096))])
(unless (eof-object? m) (loop (+ n m))))))))]
[discarded/leftovers (if need-leftover? #f 0)]
[spitout (if need-leftover?
(open-output-bytes)
(make-output-port
'counter always-evt
(lambda (s start end flush? breakable?)
(let ([c (- end start)])
(set! discarded/leftovers
(+ c discarded/leftovers))
c))
void))]
[end (and end (- end start))])
(let-values ([(ms ipre)
(regexp-match/end rx string 0 end spitout ipre
max-lookbehind)])
(let* ([m (and ms (car ms))]
[discarded/leftovers (if need-leftover?
(get-output-bytes spitout)
discarded/leftovers)]
[skipped (if need-leftover?
(bstring-length discarded/leftovers)
discarded/leftovers)]
[got (and m (bstring-length m))]
[end (and end m (- end skipped got))])
(if m
(let ([0-ok? (not (zero? got))])
(loop (port-success-choose m discarded/leftovers ms acc)
0 end ipre 0-ok?))
(port-failure-k acc discarded/leftovers)))))
;; String/port match, get positions
(let-values ([(m ipre)
(if peek?
(regexp-match-peek-positions/end rx
string start end #f ipre
max-lookbehind)
(regexp-match-positions/end rx
string start end #f ipre
max-lookbehind))])
(if (not m)
(failure-k acc start end)
(let* ([mstart (caar m)]
[mend (cdar m)]
[0-ok? (not (= mstart mend))])
(if port-success-k
(port-success-k
(lambda (acc new-start new-end)
(loop acc new-start new-end ipre 0-ok?))
acc start end mstart mend)
(loop (success-choose start mstart mend m acc)
mend end ipre 0-ok?)))))))))))
;; String/port match, get positions
(let-values ([(m ipre)
(if peek?
(regexp-match-peek-positions/end
rx string start end #f ipre
max-lookbehind)
(regexp-match-positions/end
rx string start end #f ipre
max-lookbehind))])
(if (not m)
(failure-k acc start end)
(let* ([mstart (caar m)]
[mend (cdar m)]
[0-ok? (not (= mstart mend))])
(if port-success-k
(port-success-k
(lambda (acc new-start new-end)
(loop acc new-start new-end ipre 0-ok?))
acc start end mstart mend)
(loop (success-choose start mstart mend m acc)
mend end ipre 0-ok?)))))))))))
;; Returns all the positions at which the pattern matched.
(define (regexp-match-positions* pattern string [start 0] [end #f] [ipre #""])
(regexp-loop
regexp-match-positions* loop start end
pattern string
ipre
;; success-choose:
(lambda (start mstart mend ms acc) (cons (cons mstart mend) acc))
;; failure-k:
(lambda (acc start end) acc)
;; port-success-k: need to shift index of rest as reading; cannot
;; do a tail call without adding another state variable to the
;; regexp loop, so this remains inefficient
(and (input-port? string)
(lambda (loop acc start end mstart mend)
(append (map (lambda (p)
(cons (+ mend (car p)) (+ mend (cdr p))))
(loop '() 0 (and end (- end mend))))
(cons (cons mstart mend) acc))))
;; other port functions: use string case
#f
#f
#f
#f))
(regexp-loop regexp-match-positions* loop start end pattern string ipre
;; success-choose:
(lambda (start mstart mend ms acc) (cons (cons mstart mend) acc))
;; failure-k:
(lambda (acc start end) acc)
;; port-success-k: need to shift index of rest as reading; cannot
;; do a tail call without adding another state variable to the
;; regexp loop, so this remains inefficient
(and (input-port? string)
(lambda (loop acc start end mstart mend)
(append (map (lambda (p)
(cons (+ mend (car p)) (+ mend (cdr p))))
(loop '() 0 (and end (- end mend))))
(cons (cons mstart mend) acc))))
;; other port functions: use string case
#f
#f
#f
#f))
;; Returns all the positions at which the pattern matched.
(define (regexp-match-peek-positions* pattern string [start 0] [end #f] [ipre #""])
(regexp-loop
regexp-match-peek-positions* loop start end
pattern string
ipre
;; success-choose:
(lambda (start mstart mend ms acc) (cons (cons mstart mend) acc))
;; failure-k:
(lambda (acc start end) acc)
;; port functions: use string case
#f
#f
#f
#f
#t))
(define (regexp-match-peek-positions* pattern string [start 0] [end #f]
[ipre #""])
(regexp-loop regexp-match-peek-positions* loop start end
pattern string ipre
;; success-choose:
(lambda (start mstart mend ms acc) (cons (cons mstart mend) acc))
;; failure-k:
(lambda (acc start end) acc)
;; port functions: use string case
#f
#f
#f
#f
#t))
;; Splits a string into a list by removing any piece which matches
;; the pattern.
(define (regexp-split pattern string [start 0] [end #f] [ipre #""])
(define buf (if (and (string? string) (or (byte-regexp? pattern)
(bytes? pattern)))
(string->bytes/utf-8 string (char->integer #\?))
string))
(define sub (if (or (bytes? buf) (and (path? string)
(or (bytes? pattern)
(byte-regexp? pattern))))
subbytes
substring))
(define buf
(if (and (string? string) (or (byte-regexp? pattern) (bytes? pattern)))
(string->bytes/utf-8 string (char->integer #\?))
string))
(define sub
(if (or (bytes? buf)
(and (path? string)
(or (bytes? pattern) (byte-regexp? pattern))))
subbytes
substring))
(regexp-loop regexp-split loop start end pattern buf ipre
;; success-choose:
(lambda (start mstart mend ms acc) (cons (sub buf start mstart) acc))
;; failure-k:
(lambda (acc start end)
(cons (if end (sub buf start end) (sub buf start)) acc))
;; port-success-k:
#f
;; port-success-choose:
(lambda (match-string leftovers ms acc) (cons leftovers acc))
;; port-failure-k:
(lambda (acc leftover) (if leftover (cons leftover acc) acc))
#t
#f))
;; success-choose:
(lambda (start mstart mend ms acc) (cons (sub buf start mstart) acc))
;; failure-k:
(lambda (acc start end)
(cons (if end (sub buf start end) (sub buf start)) acc))
;; port-success-k:
#f
;; port-success-choose:
(lambda (match-string leftovers ms acc) (cons leftovers acc))
;; port-failure-k:
(lambda (acc leftover) (if leftover (cons leftover acc) acc))
#t
#f))
;; Like splitting, but insert a replacement between matches
(define -regexp-replace*
(let ([regexp-replace*
(lambda (pattern string orig-replacement [ipre #""])
(define buf (if (and (string? string) (or (byte-regexp? pattern)
(bytes? pattern)))
(string->bytes/utf-8 string (char->integer #\?))
string))
(define buf
(if (and (string? string)
(or (byte-regexp? pattern) (bytes? pattern)))
(string->bytes/utf-8 string (char->integer #\?))
string))
(define sub (if (bytes? buf) subbytes substring))
(define start 0)
(define end #f)
(define needs-string?
(and (or (string? pattern) (regexp? pattern))
(string? string)))
(and (or (string? pattern) (regexp? pattern)) (string? string)))
(define replacement
(if (and (not needs-string?) (string? orig-replacement))
(string->bytes/utf-8 orig-replacement)
orig-replacement))
(string->bytes/utf-8 orig-replacement)
orig-replacement))
(define (check proc args)
(let ([v (apply proc args)])
(unless (if needs-string?
(string? v)
(bytes? v))
(raise-mismatch-error '|regexp-replace* (calling given filter procedure)|
(if needs-string?
"expected a string result: "
"expected a byte string result: ")
v))
(unless (if needs-string? (string? v) (bytes? v))
(raise-mismatch-error
'|regexp-replace* (calling given filter procedure)|
(if needs-string?
"expected a string result: "
"expected a byte string result: ")
v))
v))
(define need-replac? (and (not (procedure? replacement))
(regexp-match? #rx#"[\\&]" replacement)))
(define need-replac?
(and (not (procedure? replacement))
(regexp-match? #rx#"[\\&]" replacement)))
(define (replac ms str)
(if need-replac?
((if (string? str) bytes->string/utf-8 values)
(apply
bytes-append
(let ([str (if (string? str) (string->bytes/utf-8 str) str)]
[get-match (lambda (n)
(if (n . < . (length ms))
(let* ([p (list-ref ms n)]
[s (if (pair? p)
(sub buf (car p) (cdr p))
p)])
(if (string? s)
(string->bytes/utf-8 s)
s))
#""))])
(let loop ([pos 0])
(let ([m (regexp-match-positions #rx#"[\\&]" str pos)])
(if m
(cons (subbytes str pos (caar m))
(cond
[(equal? (char->integer #\&) (bytes-ref str (caar m)))
(cons (get-match 0) (loop (cdar m)))]
[(= (cdar m) (bytes-length str))
;; \ with no following character
(list (get-match 0))]
[(let ([next (bytes-ref str (cdar m))])
(or (and (equal? (char->integer #\&) next)
#"&")
(and (equal? (char->integer #\\) next)
#"\\")))
=> (lambda (s)
(cons s (loop (add1 (cdar m)))))]
[else
(let ([n (regexp-match #rx#"^[0-9]+" str (cdar m))])
(if n
(cons (get-match (string->number (bytes->string/utf-8 (car n))))
(loop (+ (cdar m) (bytes-length (car n)))))
(cons (get-match 0)
(loop (cdar m)))))]))
(list (subbytes str pos))))))))
str))
((if (string? str) bytes->string/utf-8 values)
(apply
bytes-append
(let ([str (if (string? str) (string->bytes/utf-8 str) str)]
[get-match
(lambda (n)
(if (n . < . (length ms))
(let* ([p (list-ref ms n)]
[s (if (pair? p)
(sub buf (car p) (cdr p))
p)])
(if (string? s) (string->bytes/utf-8 s) s))
#""))])
(let loop ([pos 0])
(let ([m (regexp-match-positions #rx#"[\\&]" str pos)])
(if m
(cons (subbytes str pos (caar m))
(cond
[(equal? (char->integer #\&)
(bytes-ref str (caar m)))
(cons (get-match 0) (loop (cdar m)))]
[(= (cdar m) (bytes-length str))
;; \ with no following character
(list (get-match 0))]
[(let ([next (bytes-ref str (cdar m))])
(or (and (equal? (char->integer #\&) next)
#"&")
(and (equal? (char->integer #\\) next)
#"\\")))
=> (lambda (s)
(cons s (loop (add1 (cdar m)))))]
[else
(let ([n (regexp-match #rx#"^[0-9]+" str
(cdar m))])
(if n
(cons (get-match (string->number
(bytes->string/utf-8
(car n))))
(loop (+ (cdar m)
(bytes-length (car n)))))
(cons (get-match 0)
(loop (cdar m)))))]))
(list (subbytes str pos))))))))
str))
(when (or (string? pattern) (bytes? pattern)
(regexp? pattern) (byte-regexp? pattern))
(regexp? pattern) (byte-regexp? pattern))
(unless (or (string? string)
(bytes? string))
(raise-type-error 'regexp-replace* "string or byte string" string))
(raise-type-error 'regexp-replace* "string or byte string"
string))
(unless (or (string? replacement)
(bytes? replacement)
(procedure? replacement))
(raise-type-error 'regexp-replace* "string, byte string, or procedure"
(raise-type-error 'regexp-replace*
"string, byte string, or procedure"
replacement))
(when (and needs-string? (bytes? replacement))
(raise-mismatch-error 'regexp-replace*
"cannot replace a string with a byte string: "
replacement)))
(raise-mismatch-error
'regexp-replace*
"cannot replace a string with a byte string: "
replacement)))
(apply
(if (bytes? buf) bytes-append string-append)
(regexp-loop
regexp-replace* loop start end pattern buf ipre
;; success-choose:
(lambda (start mstart mend ms acc) (list* (if (procedure? replacement)
(check
replacement
(for/list ([m ms])
(and m (sub buf (car m) (cdr m)))))
(replac ms replacement))
(sub buf start mstart)
acc))
;; failure-k:
(lambda (acc start end)
(cons (if end (sub buf start end) (sub buf start)) acc))
;; port-success-k:
#f
;; port-success-choose:
#f
;; port-failure-k:
#f
#t
#f)))])
(regexp-loop regexp-replace* loop start end pattern buf ipre
;; success-choose:
(lambda (start mstart mend ms acc)
(list* (if (procedure? replacement)
(check
replacement
(for/list ([m ms])
(and m (sub buf (car m) (cdr m)))))
(replac ms replacement))
(sub buf start mstart)
acc))
;; failure-k:
(lambda (acc start end)
(cons (if end (sub buf start end) (sub buf start)) acc))
;; port-success-k:
#f
;; port-success-choose:
#f
;; port-failure-k:
#f
#t
#f)))])
regexp-replace*))
;; Returns all the matches for the pattern in the string.
(define (regexp-match* pattern string [start 0] [end #f] [ipre #""])
(define buf (if (and (string? string) (or (byte-regexp? pattern)
(bytes? pattern)))
(string->bytes/utf-8 string (char->integer #\?))
string))
(define sub (if (or (bytes? buf) (and (path? string)
(or (bytes? pattern)
(byte-regexp? pattern))))
subbytes
substring))
(define buf
(if (and (string? string) (or (byte-regexp? pattern) (bytes? pattern)))
(string->bytes/utf-8 string (char->integer #\?))
string))
(define sub
(if (or (bytes? buf)
(and (path? string)
(or (bytes? pattern) (byte-regexp? pattern))))
subbytes
substring))
(regexp-loop regexp-match* loop start end pattern buf ipre
;; success-choose:
(lambda (start mstart mend ms acc) (cons (sub buf mstart mend) acc))
;; failure-k:
(lambda (acc start end) acc)
;; port-success-k:
#f
;; port-success-choose:
(lambda (match-string leftovers ms acc) (cons match-string acc))
;; port-failure-k:
(lambda (acc leftover) acc)
#f
#f))
;; success-choose:
(lambda (start mstart mend ms acc) (cons (sub buf mstart mend) acc))
;; failure-k:
(lambda (acc start end) acc)
;; port-success-k:
#f
;; port-success-choose:
(lambda (match-string leftovers ms acc) (cons match-string acc))
;; port-failure-k:
(lambda (acc leftover) acc)
#f
#f))
(define (regexp-match-exact? p s)
(let ([m (regexp-match-positions p s)])
@ -453,11 +457,11 @@
(cond [(bytes? s) (bytes-length s)]
[(or (byte-regexp? p) (bytes? p))
(if (path? s)
(bytes-length (path->bytes s))
(string-utf-8-length s))]
(bytes-length (path->bytes s))
(string-utf-8-length s))]
[else
(if (path? s)
(string-length (path->string s))
(string-length s))])))))
(string-length (path->string s))
(string-length s))])))))
)