add regex-pure-literal-alts for pure-literal alternation extraction
ober
0175672a6df037bd54f3bd4c6e673e89840059b1
--- a/lib/std/regex.ss +++ b/lib/std/regex.ss @@ -46,7 +46,8 @@ ;; Internal accessor used by (std rx) for pattern splicing re-object-pat-string ;; Required-literal extraction (for multi-pattern pre-filtering) - regex-required-literal) + regex-required-literal + regex-pure-literal-alts) (import (chezscheme) (std pregexp) @@ -630,4 +631,176 @@ (fx- (char->integer c) (char->integer #\0))))] [else (values acc k)]))]))) + ;; ========== Pure-literal alternation extraction ========== + ;; + ;; If PATTERN is structurally `^?(L1|L2|...|Ln)$?` where each Li is a + ;; literal byte sequence (a non-empty run of plain chars and simple + ;; escapes — no char classes, quantifiers, groups, anchors, or back- + ;; references), return the list (L1 L2 ... Ln). Otherwise return #f. + ;; + ;; Callers can use this to fan a single regex spec out into N literal + ;; anchors: any occurrence of any Li is a candidate; no regex engine + ;; needed. The outer `(...)` is required so we know the alternation + ;; spans the entire pattern; bare `a|b` (no parens) also qualifies. + ;; + ;; Examples that return a list: + ;; "(curl|wget)" -> ("curl" "wget") + ;; "(Login Data|Cookies|Web Data)" -> ("Login Data" ...) + ;; "^(rx/0|cn/r|kawpow|cn-pico)$" -> ("rx/0" "cn/r" ...) + ;; "(wallet\\.dat|keystore|Ethereum\\\\xx)" -> ("wallet.dat" ...) + ;; + ;; Examples that return #f: + ;; "(curl|wget)[ \\t]+sh" — content outside the alternation + ;; "(key[34]\\.db|...)" — a branch contains a char class + ;; "(A|B(C|D))" — a branch contains a nested group + ;; "single-literal" — no alternation + ;; "(A)" — single branch (caller should use the + ;; regex-required-literal path) + (def (regex-pure-literal-alts pattern) + (let ([str (cond + [(re-object? pattern) (re-object-pat-string pattern)] + [(string? pattern) pattern] + [else (error 'regex-pure-literal-alts + "pattern must be a string or re object" pattern)])]) + (let ([n (string-length str)]) + (cond + [(fxzero? n) #f] + [else + (let-values ([(start end) (pla-strip-anchors str 0 n)]) + (let-values ([(parens? istart iend) (pla-strip-outer-parens str start end)]) + (let ([alts (pla-split-alts str istart iend parens?)]) + (cond + [(or (not alts) (null? alts) (null? (cdr alts))) #f] + [else alts]))))])))) + + ;; Strip optional ^ at start and $ at end. Returns the inner range. + (def (pla-strip-anchors s start end) + (let* ([s2 (if (and (fx< start end) (char=? (string-ref s start) #\^)) + (fx+ start 1) start)] + [e2 (if (and (fx< s2 end) (char=? (string-ref s (fx- end 1)) #\$)) + (fx- end 1) end)]) + (values s2 e2))) + + ;; If the range is wrapped in a single non-capturing or capturing group + ;; that spans the entire range, strip the parens. Otherwise leave as-is. + ;; Returns (values parens? new-start new-end). + (def (pla-strip-outer-parens s start end) + (cond + [(and (fx< start end) + (char=? (string-ref s start) #\()) + (let-values ([(after-prefix ok?) (rl-skip-group-prefix s (fx+ start 1) end)]) + (cond + [(not ok?) (values #f start end)] + [else + ;; Find the matching close-paren at the SAME depth. + (let walk ([i after-prefix] [depth 0]) + (cond + [(fx>= i end) (values #f start end)] + [else + (let ([c (string-ref s i)]) + (cond + [(char=? c #\\) + (if (fx< (fx+ i 1) end) + (walk (fx+ i 2) depth) + (values #f start end))] + [(char=? c #\[) + (let ([k (rl-skip-class s (fx+ i 1) end)]) + (if k (walk k depth) (values #f start end)))] + [(char=? c #\() + (walk (fx+ i 1) (fx+ depth 1))] + [(char=? c #\)) + (cond + [(fxzero? depth) + ;; Matched the outer paren. Require it to + ;; be at the end of the range; if not, the + ;; group is followed by more content. + (cond + [(fx= (fx+ i 1) end) + (values #t after-prefix i)] + [else (values #f start end)])] + [else (walk (fx+ i 1) (fx- depth 1))])] + [else (walk (fx+ i 1) depth)]))]))]))] + [else (values #f start end)])) + + ;; Split `s[start..end]` on top-level `|`. Returns the list of branch + ;; literal strings if every branch is a pure literal sequence; #f if + ;; any branch fails the pure-literal check. + ;; + ;; If `had-parens?` is #f and we find no `|`, the input is not an + ;; alternation at all — return a single-branch list; caller can detect + ;; len<2 and reject. + (def (pla-split-alts s start end had-parens?) + (let loop ([i start] [branch-start start] [out '()]) + (cond + [(fx>= i end) + (let ([branch (pla-extract-literal s branch-start end)]) + (cond + [(not branch) #f] + [else (reverse (cons branch out))]))] + [else + (let ([c (string-ref s i)]) + (cond + [(char=? c #\\) + (cond + [(fx>= (fx+ i 1) end) #f] + [else (loop (fx+ i 2) branch-start out)])] + [(char=? c #\[) + ;; A char class can't appear in a pure-literal branch. + #f] + [(char=? c #\() + ;; A nested group can't appear in a pure-literal branch. + #f] + [(char=? c #\|) + (let ([branch (pla-extract-literal s branch-start i)]) + (cond + [(not branch) #f] + [else (loop (fx+ i 1) (fx+ i 1) (cons branch out))]))] + [else (loop (fx+ i 1) branch-start out)]))]))) + + ;; Extract the literal string from `s[start..end]`. Returns the + ;; decoded literal or #f if the range contains any non-literal char. + ;; Disallows: `?` `*` `+` `{` `}` `.` `^` `$` (i.e. regex + ;; metacharacters). Backslash escapes for `\n`, `\r`, `\t`, `\f`, `\v` + ;; lower to control chars; other plain `\C` escapes lower to `C`. + ;; `\d`, `\D`, `\w`, `\W`, `\s`, `\S`, `\b`, `\B` etc are rejected. + (def (pla-extract-literal s start end) + (cond + [(fx>= start end) #f] ;; empty branch — not a pure literal + [else + (let ([buf (make-string (fx- end start))]) + (let loop ([i start] [k 0]) + (cond + [(fx>= i end) + (cond + [(fxzero? k) #f] + [else (substring buf 0 k)])] + [else + (let ([c (string-ref s i)]) + (cond + [(or (char=? c #\.) (char=? c #\?) (char=? c #\*) + (char=? c #\+) (char=? c #\{) (char=? c #\}) + (char=? c #\^) (char=? c #\$) + (char=? c #\[) (char=? c #\]) (char=? c #\()) + #f] + [(char=? c #\\) + (cond + [(fx>= (fx+ i 1) end) #f] + [else + (let ([e (string-ref s (fx+ i 1))]) + (cond + [(memv e '(#\d #\D #\w #\W #\s #\S + #\b #\B #\A #\Z #\z + #\x #\u #\0 #\1 #\2 #\3 #\4 + #\5 #\6 #\7 #\8 #\9)) + #f] + [(memv e '(#\n #\r #\t #\f #\v)) + (string-set! buf k (rl-escape->char e)) + (loop (fx+ i 2) (fx+ k 1))] + [else + (string-set! buf k e) + (loop (fx+ i 2) (fx+ k 1))]))])] + [else + (string-set! buf k c) + (loop (fx+ i 1) (fx+ k 1))]))])))])) + ) ;; end library