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

fixed some stuff, added tests, added simple option (no ranges)

Browse Source 
svn: r4935

original commit: f902ea5ba94950312a65b4e053cce635f8ecefe2
This commit is contained in:
Eli Barzilay 2006-11-23 17:38:53 +00:00
parent 28a09920e8
commit b5e99cbd94
1 changed files with 37 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/mzlib/string.ss
View File

@ -404,34 +404,35 @@
#f))
(wrap regexp-match* -regexp-match*)
(define regexp-match-exact?
(lambda (p s)
(let ([m (regexp-match-positions p s)])
(and m
(zero? (caar m))
(if (or (byte-regexp? p)
(bytes? p)
(bytes? s))
(= (cdar m) (if (bytes? s)
(bytes-length s)
(string-utf-8-length s)))
(= (cdar m) (string-length s)))))))
(define (regexp-match-exact? p s)
(let ([m (regexp-match-positions p s)])
(and m
(zero? (caar m))
(if (or (byte-regexp? p) (bytes? p) (bytes? s))
(= (cdar m) (if (bytes? s)
(bytes-length s)
(string-utf-8-length s)))
(= (cdar m) (string-length s))))))
(define glob->regexp
(let-values
([(def-case-sens) (not (memq (system-type) '(windows macos macosx)))]
[(item:s item:b)
(let ([rx (string-append
"(?:"
"[\\]." ; escaped item
"|"
"[*?]" ; wildcards -- the only 1-character match
"|"
"\\[(?:\\^?\\]|\\^?[^]^])[^]]*\\]" ; range
")"
)])
(values (regexp rx) (byte-regexp (string->bytes/utf-8 rx))))])
(opt-lambda (glob [hide-dots? #t] [case-sens? def-case-sens])
[(item:s item:b simple-item:s simple-item:b)
(let ([rx (lambda (s)
(string-append
"(?:"
"[\\]." ; escaped item
"|"
"[*?]" ; wildcards -- the only 1-character match
s ; [*] more stuff here
")"
))]
[range "|\\[(?:\\^?\\]|\\^?[^]^])[^]]*\\]"]) ; goes in [*]
(values (regexp (rx range))
(byte-regexp (string->bytes/utf-8 (rx range)))
(regexp (rx ""))
(byte-regexp (string->bytes/utf-8 (rx "")))))])
(opt-lambda (glob [hide-dots? #t] [case-sens? def-case-sens] [simple? #f])
(let*-values ([(b?) (cond [(bytes? glob) #t]
[(string? glob) #f]
[else (raise-type-error
@ -440,9 +441,11 @@
[(app sub ref rx item star any one)
(if b?
(values bytes-append subbytes bytes-ref byte-regexp
item:b (char->integer #\*) #".*" #".")
(if simple? simple-item:b item:b)
(char->integer #\*) #".*" #".")
(values string-append substring string-ref regexp
item:s #\* ".*" "."))]
(if simple? simple-item:s item:s)
#\* ".*" "."))]
[(pfx sfx) (if case-sens?
(if b? (values #"^" #"^")
(values "^" "$"))
@ -450,21 +453,22 @@
(values "^(?i:" ")$")))]
[(pfx) (if hide-dots?
(app pfx (if b? #"(?![.])" "(?![.])"))
pfx)])
pfx)]
[(subq) (lambda xs (regexp-quote (apply sub xs)))])
(let loop ([i 0] [ps (regexp-match-positions* item glob)] [r '()])
(cond [(null? ps)
(rx (app pfx
(apply app (reverse! (cons (sub glob i) r)))
sfx))]
(let ([r (apply app (reverse! (cons (subq glob i) r)))])
(rx (app pfx r sfx)))]
[(= 1 (- (cdar ps) (caar ps)))
(loop (cdar ps)
(cdr ps)
(cons (if (equal? star (ref glob (caar ps))) any one)
(if (= i (caar ps))
r
(cons (sub glob i (caar ps)) r))))]
r (cons (subq glob i (caar ps)) r))))]
[else (loop (cdar ps)
(cdr ps)
(cons (sub glob i (cdar ps)) r))]))))))
(cons (sub glob (caar ps) (cdar ps))
(if (= i (caar ps))
r (cons (subq glob i (caar ps)) r))))]))))))
)