285 lines
11 KiB
Scheme
285 lines
11 KiB
Scheme
(module string "pre-base.ss"
|
|
|
|
(provide real->decimal-string
|
|
regexp-quote
|
|
regexp-replace-quote
|
|
regexp-match*
|
|
regexp-match-positions*
|
|
regexp-match-peek-positions*
|
|
regexp-split
|
|
regexp-match-exact?
|
|
regexp-try-match)
|
|
(require (for-syntax "stxcase-scheme.ss"))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (real->decimal-string n [digits 2])
|
|
(let* ([e (expt 10 digits)]
|
|
[num (round (abs (* e (inexact->exact n))))])
|
|
(format "~a~a.~a"
|
|
(if (negative? n) "-" "")
|
|
(quotient num e)
|
|
(let ([s (number->string (remainder num e))])
|
|
(if (= (string-length s) digits)
|
|
s
|
|
(string-append (make-string (- digits (string-length s)) #\0)
|
|
s))))))
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Regexp helpers
|
|
|
|
(define (bstring-length s)
|
|
(if (bytes? s) (bytes-length s) (string-length s)))
|
|
|
|
(define (bstring->regexp name pattern)
|
|
(cond [(regexp? pattern) pattern]
|
|
[(byte-regexp? pattern) pattern]
|
|
[(string? pattern) (regexp pattern)]
|
|
[(bytes? pattern) (byte-regexp pattern)]
|
|
[else (raise-type-error
|
|
name "regexp, byte regexp, string, or byte string" pattern)]))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Regexp helpers
|
|
|
|
(define regexp-quote-chars:s #rx"[][.*?+|(){}\\$^]")
|
|
(define regexp-quote-chars:b #rx#"[][.*?+|(){}\\$^]")
|
|
|
|
(define (regexp-quote s [case-sens? #t])
|
|
(let* ([b? (cond [(bytes? s) #t]
|
|
[(string? s) #f]
|
|
[else (raise-type-error 'regexp-quote
|
|
"string or byte string" s)])]
|
|
[s (if b?
|
|
(regexp-replace* regexp-quote-chars:b s #"\\\\&")
|
|
(regexp-replace* regexp-quote-chars:s s "\\\\&"))])
|
|
(cond [case-sens? s]
|
|
[b? (bytes-append #"(?i:" s #")")]
|
|
[else (string-append "(?i:" s ")")])))
|
|
|
|
(define (regexp-replace-quote s)
|
|
(cond [(bytes? s) (regexp-replace* #rx#"[&\\]" s #"\\\\&")]
|
|
[(string? s) (regexp-replace* #rx"[&\\]" s "\\\\&")]
|
|
[else (raise-type-error 'regexp-replace-quote
|
|
"string or byte string" s)]))
|
|
|
|
(define (regexp-try-match pattern input-port [start-k 0] [end-k #f] [out #f])
|
|
(unless (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)])
|
|
(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)))
|
|
;; Get the matching part, and shift matching indicies
|
|
(let ([s (read-bytes (- (cdar m) drop) input-port)])
|
|
(cons s
|
|
(map (lambda (p)
|
|
(and p (subbytes s (- (car p) drop) (- (cdr p) drop))))
|
|
(cdr m))))))))
|
|
|
|
;; Helper function for the regexp functions below.
|
|
(define-syntax make-regexp-loop
|
|
(syntax-rules ()
|
|
[(make-regexp-loop
|
|
name rx string success-k port-success-k failure-k port-failure-k
|
|
need-leftover? peek?)
|
|
(let ([len (cond [(string? string) (string-length string)]
|
|
[(bytes? string) (bytes-length string)]
|
|
[else #f])])
|
|
(if peek?
|
|
(unless (input-port? string)
|
|
(raise-type-error name "input port" string))
|
|
(unless (or len (input-port? string))
|
|
(raise-type-error name "string, byte string or input port" string)))
|
|
(lambda (acc start end)
|
|
(unless (and (number? start) (exact? start) (integer? start)
|
|
(start . >= . 0))
|
|
(raise-type-error name "non-negative exact integer" start))
|
|
(unless (or (not end)
|
|
(and (number? end) (exact? end) (integer? end)
|
|
(end . >= . 0)))
|
|
(raise-type-error name "non-negative exact integer or false" end))
|
|
(unless (or (input-port? string) (and len (start . <= . len)))
|
|
(raise-mismatch-error
|
|
name
|
|
(format "starting offset index out of range [0,~a]: " len)
|
|
start))
|
|
(unless (or (not end)
|
|
(and (start . <= . end)
|
|
(or (input-port? string)
|
|
(and len (end . <= . len)))))
|
|
(raise-mismatch-error
|
|
name
|
|
(format "ending offset index out of range [~a,~a]: " start len)
|
|
end))
|
|
|
|
(when (and (positive? start) (input-port? string) need-leftover?)
|
|
;; 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))))))))
|
|
|
|
(if (and (input-port? string) port-success-k)
|
|
;; Input port match, get string
|
|
(let ([discarded 0]
|
|
[leftover-port (and need-leftover? (open-output-bytes))])
|
|
(let ([match
|
|
(regexp-match
|
|
rx string
|
|
(if need-leftover? 0 start)
|
|
(and end (if need-leftover? (- end start) end))
|
|
(if need-leftover?
|
|
leftover-port
|
|
(make-output-port
|
|
'counter
|
|
always-evt
|
|
(lambda (s start end flush? breakable?)
|
|
(let ([c (- end start)])
|
|
(set! discarded (+ c discarded))
|
|
c))
|
|
void)))]
|
|
[leftovers
|
|
(and need-leftover?
|
|
(if (and (regexp? rx) (string? string))
|
|
(get-output-string leftover-port)
|
|
(get-output-bytes leftover-port)))])
|
|
(if match
|
|
(port-success-k
|
|
acc
|
|
(car match)
|
|
(and end (- end (if need-leftover?
|
|
(+ (bstring-length leftovers) start)
|
|
discarded)
|
|
(bstring-length (car match))))
|
|
leftovers)
|
|
(port-failure-k acc leftovers))))
|
|
;; String/port match, get positions
|
|
(let ([match ((if peek?
|
|
regexp-match-peek-positions
|
|
regexp-match-positions)
|
|
rx string start end)])
|
|
(if match
|
|
(let ([match-start (caar match)]
|
|
[match-end (cdar match)])
|
|
(if (= match-start match-end)
|
|
(error name
|
|
"pattern matched a zero-length substring: ~e" rx)
|
|
(success-k acc start end match-start match-end)))
|
|
(failure-k acc start end))))))]))
|
|
|
|
;; Returns all the positions at which the pattern matched.
|
|
(define (regexp-match-positions* pattern string [start 0] [end #f])
|
|
(define rx (bstring->regexp 'regexp-match-positions* pattern))
|
|
(define loop
|
|
(make-regexp-loop
|
|
'regexp-match-positions* rx string
|
|
;; success-k:
|
|
(lambda (acc start end match-start match-end)
|
|
(let ([acc (cons (cons match-start match-end) acc)])
|
|
(if (or (string? string) (bytes? string))
|
|
(loop acc match-end end)
|
|
;; Need to shift index of rest as reading, cannot do a
|
|
;; tail call without adding another state variable to the loop:
|
|
(append (map (lambda (p)
|
|
(cons (+ match-end (car p)) (+ match-end (cdr p))))
|
|
(loop '() 0 (and end (- end match-end))))
|
|
acc))))
|
|
;; port-success-k: use string case
|
|
#f
|
|
;; failure-k:
|
|
(lambda (acc start end) acc)
|
|
;; port-fail-k: use string case
|
|
#f
|
|
#f
|
|
#f))
|
|
(reverse (loop '() start end)))
|
|
|
|
;; Returns all the positions at which the pattern matched.
|
|
(define (regexp-match-peek-positions* pattern string [start 0] [end #f])
|
|
(define rx (bstring->regexp 'regexp-match-peek-positions* pattern))
|
|
(define loop
|
|
(make-regexp-loop
|
|
'regexp-match-peek-positions* rx string
|
|
;; success-k:
|
|
(lambda (acc start end match-start match-end)
|
|
(loop (cons (cons match-start match-end) acc) match-end end))
|
|
;; port-success-k: use string case
|
|
#f
|
|
;; failure-k:
|
|
(lambda (acc start end) acc)
|
|
;; port-fail-k: use string case
|
|
#f
|
|
#f
|
|
#t))
|
|
(reverse (loop '() start end)))
|
|
|
|
;; Splits a string into a list by removing any piece which matches
|
|
;; the pattern.
|
|
(define (regexp-split pattern string [start 0] [end #f])
|
|
(define rx (bstring->regexp 'regexp-split pattern))
|
|
(define buf (if (and (string? string) (byte-regexp? rx))
|
|
(string->bytes/utf-8 string (char->integer #\?))
|
|
string))
|
|
(define sub (if (bytes? buf) subbytes substring))
|
|
(define loop
|
|
(make-regexp-loop
|
|
'regexp-split rx buf
|
|
;; success-k:
|
|
(lambda (acc start end match-start match-end)
|
|
(loop (cons (sub buf start match-start) acc) match-end end))
|
|
;; port-success-k:
|
|
(lambda (acc match-string new-end leftovers)
|
|
(loop (cons leftovers acc) 0 new-end))
|
|
;; failure-k:
|
|
(lambda (acc start end)
|
|
(cons (sub buf start (or end (bstring-length buf))) acc))
|
|
;; port-fail-k
|
|
(lambda (acc leftover) (cons leftover acc))
|
|
#t
|
|
#f))
|
|
(reverse (loop '() start end)))
|
|
|
|
;; Returns all the matches for the pattern in the string.
|
|
(define (regexp-match* pattern string [start 0] [end #f])
|
|
(define rx (bstring->regexp 'regexp-match* pattern))
|
|
(define buf (if (and (string? string) (byte-regexp? rx))
|
|
(string->bytes/utf-8 string (char->integer #\?))
|
|
string))
|
|
(define sub (if (bytes? buf) subbytes substring))
|
|
(define loop
|
|
(make-regexp-loop
|
|
'regexp-match* rx buf
|
|
;; success-k:
|
|
(lambda (acc start end match-start match-end)
|
|
(loop (cons (sub buf match-start match-end) acc) match-end end))
|
|
;; port-success-k:
|
|
(lambda (acc match-string new-end leftovers)
|
|
(loop (cons match-string acc) 0 new-end))
|
|
;; failure-k:
|
|
(lambda (acc start end) acc)
|
|
;; port-fail-k:
|
|
(lambda (acc leftover) acc)
|
|
#f
|
|
#f))
|
|
(reverse (loop '() start end)))
|
|
|
|
(define (regexp-match-exact? p s)
|
|
(let ([m (regexp-match-positions p s)])
|
|
(and m (zero? (caar m))
|
|
(= (cdar m)
|
|
(cond [(bytes? s) (bytes-length s)]
|
|
[(or (byte-regexp? p) (bytes? p)) (string-utf-8-length s)]
|
|
[else (string-length s)])))))
|
|
|
|
)
|