;;; Olin Shivers, June 1998
;;; Copyright (c) 1998 by the Scheme Underground.
;;; One export: (simplify-regexp re) -> re
;;; Regexp simplifier
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (| (in c1 ...) (in c2 ...) re ...) => (| (in c1 ... c2 ...) re ...)
;;; (| (not-in c1 ...) (not-in c2 ...)) => (| (not-in [intersect (c1 ...)
;;; (c2 ...)])
;;; A run of BOS's or a run of EOS's in a sequence may be elided.
;;; Nested exponents can be collapsed (*, +, ?) -- multiply the "from's"
;;; together; multiply the "to's" together.
;;; Exponent range [1,1] simplifies, as does [0,0].
;;; Uniquify branches
;;; Adjacent literals in a sequence can be collapsed
;;; A singleton-char char class can be collapsed into a constant
;;; Nested choices can be collapsed
;;; Nested sequences can be collapsed
;;; An empty sequence (:) can be turned into an empty-string match "".
;;; Singleton choices and sequences can be reduced to their body.
;;;
;;; The simplifier is carefully written so that it won't blow up
;;; when applied to a dynamic regexp -- that is,
;;; - a chunk of Scheme code that produces a regexp instead of
;;; an actual regexp value;
;;; - a repeat regexp whose FROM or TO fields are chunks of Scheme code
;;; rather than integers;
;;; - a char-set regexp whose CSET field is a chunk of Scheme code rather
;;; than an actual char-set value.
;;; This is useful because the RX macro can build such a regexp as part
;;; of its expansion process.
(define (simplify-regexp re)
(receive (simp-re pre-dsm) (simp-re re)
(re-dsm simp-re pre-dsm (- (re-tsm re) (+ (re-tsm simp-re) pre-dsm)))))
(define (simp-re re)
(? ((re-string? re) (values re 0))
((re-seq? re) (simp-seq re))
((re-choice? re) (simp-choice re))
;; Singleton char-sets reduce to the character.
;; Bear in mind the cset field might be Scheme code instead
;; of an actual char set if the regexp is dynamic.
((re-char-set? re)
(values (let ((cs (re-char-set:cset re)))
(if (and (char-set? cs)
(= 1 (char-set-size cs)))
(make-re-string (string (car (char-set->list cs))))
re))
0))
((re-repeat? re) (simp-repeat re))
((re-submatch? re) (simp-submatch re))
((re-dsm? re) (simp-dsm re))
(else (values re 0))))
;;; If the body of a submatch is the empty re, reduce it to the empty re.
(define (simp-submatch re)
(let ((tsm (re-submatch:tsm re))
(pre-dsm (re-submatch:pre-dsm re)))
(receive (body1 pre-dsm1) (simp-re (re-submatch:body re))
(if (re-empty? body1)
(values re-empty tsm)
(values (%make-re-submatch body1 (+ pre-dsm pre-dsm1) tsm)
0)))))
;;; - Flatten nested DSM's.
;;; - Return pre-dsm field and body field as the two return values.
(define (simp-dsm re)
(receive (body pre-dsm1) (simp-re (re-dsm:body re))
(values body (+ (re-dsm:pre-dsm re) pre-dsm1))))
;;; Simplifying sequences
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; - Collapse nested sequences and DSM's.
;;; - Merge adjacent strings, identical adjacent anchors (bos, eos, etc.).
;;; - Bubble DSM's forwards past elts that don't contain live submatches.
;;; (Going past live submatches would switch the submatch indexes around,
;;; which would be an error). This helps to coalesce DSMs and if we bring
;;; them all the way to the front, we can pop them off and make them a
;;; pre-dsm for the entire seq record.
;;; - If an elt is the re-empty, reduce the whole re to the empty re.
;;; - Reduce singleton and empty seq.
(define (simp-seq re)
(let ((tsm (re-seq:tsm re))
(elts (map simplify-regexp (re-seq:elts re))))
(if (pair? elts)
(call-with-current-continuation
(lambda (abort)
(receive (pre-dsm head tail) (simp-seq1 elts abort tsm)
(values (if (pair? tail)
(%make-re-seq (cons head tail) (- tsm pre-dsm))
head) ; Singleton seq
pre-dsm))))
(values re-trivial 0)))) ; Empty seq
;;; Simplify the non-empty sequence ELTS.
;;; - Return the result split out into three values:
;;; [head-elt-pre-dsm, head-elt, tail].
;;; - If any elt is the empty (impossible) re, abort by calling
;;; (abort elt tsm). TSM is otherwise unused.
(define (simp-seq1 elts abort tsm)
(let recur ((elt (car elts)) (elts (cdr elts)))
(receive (elt pre-dsm) (open-dsm elt)
(? ((re-seq? elt) ; Flatten nested seqs.
(let ((sub-elts (re-seq:elts elt)))
(recur (re-dsm (car sub-elts) pre-dsm 0)
(append (cdr sub-elts) elts))))
((re-empty? elt) (abort elt tsm)) ; Bomb out on the empty
; (impossible) re.
((pair? elts)
(receive (next-pre-dsm next tail) ; Simplify the tail,
(recur (car elts) (cdr elts)) ; then think about
; the head:
;; This guy is called when we couldn't find any other
;; simplification. If ELT contains live submatches, then
;; there really is nothing to be done at this step -- just
;; assemble the pieces together and return them. If ELT
;; *doesn't* contain any live submatches, do the same, but
;; bubble its following next-pre-dsm submatches forwards.
(define (no-simp)
(if (has-live-submatches? elt)
(values pre-dsm elt (cons (re-dsm next next-pre-dsm 0) tail))
(values (+ pre-dsm next-pre-dsm) elt (cons next tail))))
;; Coalesces two adjacent bol's, two adjacent eol's, etc.
(define (coalesce-anchor anchor?)
(if (and (anchor? elt) (anchor? next))
(values (+ pre-dsm next-pre-dsm) elt tail)
(no-simp)))
(? ((re-trivial? elt) ; Drop trivial re's.
(values (+ pre-dsm next-pre-dsm) next tail))
;; Coalesce adjacent strings
((re-string? elt)
(if (re-string? next)
(values (+ pre-dsm next-pre-dsm)
(make-re-string (string-append (re-string:chars elt)
(re-string:chars next)))
tail)
(no-simp)))
;; Coalesce adjacent bol/eol/bos/eos/bow/eow's.
((re-bol? elt) (coalesce-anchor re-bol?))
((re-eol? elt) (coalesce-anchor re-eol?))
((re-bos? elt) (coalesce-anchor re-bos?))
((re-eos? elt) (coalesce-anchor re-eos?))
((re-bow? elt) (coalesce-anchor re-bow?))
((re-eow? elt) (coalesce-anchor re-eow?))
(else (no-simp)))))
(else (values pre-dsm elt '()))))))
;;; Simplifying choices
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; - Collapse nested choices and DSM's.
;;; - Delete re-empty's.
;;; - Merge sets; merge identical anchors (bos, eos, etc.).
;;; But you can't merge across an element that contains a live submatch,
;;; see below.
;;; - A singleton string "c" is included into the char-set merge as a
;;; singleton set.
;;; - Bubble DSM's forwards past elts that don't contain live submatches.
;;; (Going past live submatches would switch the submatch indexes around,
;;; which would be an error). This helps to coalesce DSMs and if we bring
;;; them all the way to the front, we can pop them off and make them a
;;; pre-dsm for the entire seq record.
;;; - Reduce singleton and empty choice.
;;;
;;; You have to be careful simplifying choices -- you can't merge two sets
;;; that appear on different sides of an element containing a live submatch.
;;; The problem is that the assignment of submatches breaks ties left-to-right.
;;; So these aren't the same:
;;; (| (submatch "x") any) (| any (submatch "x"))
;;; The first assigns the submatch, the second doesn't -- the ANY gets credit.
;;; We want to collapse multiple char-sets, bos's, and eos's, but we have
;;; to deal with this issue. So
;;; - When we coalesce anchors, we retain the *leftmost* one.
;;; - We coalesce sets that appear between live-submatch boundaries.
;;; When we do this, we subtract from the set any char that was in
;;; an earlier coalesced char-set. If this gets us down to the empty set,
;;; we drop it. If it gets us down to a singleton set, we convert it into
;;; a singleton string.
;;; Whew. I had to think about this one.
(define (simp-choice re)
(let ((tsm (re-choice:tsm re)))
(receive (pre-dsm cset bos? eos? bol? eol? bow? eow? tail)
(simp-choice1 (map simplify-regexp (re-choice:elts re)))
(let ((tail (assemble-boundary-tail char-set:empty cset
bos? eos? bol? eol? bow? eow?
#f #f #f #f #f #f
tail)))
(values (if (pair? tail)
(if (pair? (cdr tail))
(%make-re-choice tail (- tsm pre-dsm))
(car tail)) ; Singleton choice
re-empty) ; Empty choice
pre-dsm)))))
;;; Given the return values from simp-choice1, this tacks all
;;; the various pieces (CSET, BOS?, EOS?, etc.) onto the front of
;;; TAIL. However, elements are not added onto TAIL that are already
;;; described by PREV-CSET, PREV-BOS?, etc. -- they will be added onto
;;; some earlier bit of the final result.
(define (assemble-boundary-tail prev-cset cset
bos? eos? bol? eol? bow? eow?
prev-bos? prev-eos?
prev-bol? prev-eol?
prev-bow? prev-eow?
tail)
(let* ((cset (char-set-difference cset prev-cset))
(numchars (char-set-size cset))
(tail (if (and eos? (not prev-eos?)) (cons re-eos tail) tail))
(tail (if (and eol? (not prev-eol?)) (cons re-eol tail) tail))
(tail (if (and eow? (not prev-eow?)) (cons re-eow tail) tail))
(tail (if (and bow? (not prev-bow?)) (cons re-bow tail) tail))
(tail (if (and bol? (not prev-bol?)) (cons re-bol tail) tail))
(tail (if (and bos? (not prev-bos?)) (cons re-bos tail) tail))
(tail (? ((zero? numchars) tail) ; Drop empty char set.
((= 1 numchars) ; {c} => "c"
(cons (make-re-string (string (car (char-set->list cset))))
tail))
(else (cons (make-re-char-set cset) tail)))))
tail))
;;; Simplify the non-empty list of choices ELTS.
;;; Return the result split out into the values
;;; [pre-dsm, cset, bos?, eos?, bol?, eol?, bow?, eow?, tail]
(define (simp-choice1 elts)
(let recur ((elts elts)
(prev-cset char-set:empty) ; Chars we've already seen.
(prev-bos? #f) (prev-eos? #f) ; These flags say if we've
(prev-bol? #f) (prev-eol? #f) ; already seen one of these
(prev-bow? #f) (prev-eow? #f)) ; anchors.
(if (pair? elts)
(let ((elt (car elts))
(elts (cdr elts)))
(receive (elt pre-dsm) (open-dsm elt)
(if (re-choice? elt)
;; Flatten nested choices.
(let ((sub-elts (re-seq:elts elt)))
(receive (tail-pre-dsm cset bos? eos? bol? eol? bow? eow? tail)
(recur (append sub-elts elts)
prev-cset
prev-bos? prev-eos?
prev-bol? prev-eol?
prev-bow? prev-eow?)
(values (+ pre-dsm tail-pre-dsm)
cset bos? eos? bol? eol? bow? eow? tail)))
;; Simplify the tail, then think about the head.
(receive (tail-pre-dsm cset bos? eos? bol? eol? bow? eow? tail)
(recur elts
(? ((and (re-string? elt)
(= 1 (string-length (re-string:chars elt))))
(char-set-union prev-cset
(string->char-set (re-string:chars elt))))
;; The cset might be a Scheme exp.
((and (re-char-set? elt)
(char-set? (re-char-set:cset elt)))
(char-set-union prev-cset
(re-char-set:cset elt)))
(else prev-cset))
(or prev-bos? (re-bos? elt))
(or prev-eos? (re-eos? elt))
(or prev-bol? (re-bol? elt))
(or prev-eol? (re-eol? elt))
(or prev-bow? (re-bow? elt))
(or prev-eow? (re-eow? elt)))
;; This guy is called when we couldn't find any other
;; simplification. If ELT contains live submatches, then we
;; are at a merge boundary, and have to take all the
;; TAIL-PRE-DSM, CSET, BOS?, EOS?, ... stuff we've collected
;; and tack them onto TAIL as elements, then put ELT on
;; front. Otherwise, we can commute TAIL-PRE-DSM, CSET,
;; BOS?, etc. with ELT, since it contains no live
;; submatches, so just tack ELT onto TAIL.
(define (no-simp)
(if (has-live-submatches? elt)
(let ((tail (assemble-boundary-tail prev-cset cset
bos? eos?
bol? eol?
bow? eow?
prev-bos? prev-eos?
prev-bol? prev-eol?
prev-bow? prev-eow?
tail)))
(values pre-dsm char-set:empty #f #f #f #f #f #f
(if (pair? tail)
;; Tack tail-pre-dsm onto
;; TAIL's first elt.
(cons elt
(cons (re-dsm (car tail)
tail-pre-dsm 0)
(cdr tail)))
;; Squirrel case: TAIL is empty, so use
;; TAIL-PRE-DSM as ELT's post-dsm.
(list (re-dsm elt 0 tail-pre-dsm)))))
;; ELT has no live submatches, so we can commute all
;; the recursion state forwards past it.
(values (+ pre-dsm tail-pre-dsm)
cset bos? eos? bol? eol? bow? eow?
(cons elt tail))))
(? ((and (re-char-set? elt)
(char-set? (re-char-set:cset elt))) ; Might be Scheme code
(values (+ pre-dsm tail-pre-dsm)
(char-set-union cset (re-char-set:cset elt))
bos? eos? bol? eol? bow? eow? tail))
;; Treat a singleton string "c" as a singleton set {c}.
((and (re-string? elt) (= 1 (string-length (re-string:chars elt))))
(values (+ pre-dsm tail-pre-dsm)
(char-set-union cset (string->char-set (re-string:chars elt)))
bos? eos? bol? eol? bow? eow? tail))
;; Coalesce bol/eol/bos/eos/bow/eow's.
((re-bos? elt) (values (+ pre-dsm tail-pre-dsm) cset
#t eos? bol? eol? bow? eow? tail))
((re-eos? elt) (values (+ pre-dsm tail-pre-dsm) cset
bos? #t bol? eol? bow? eow? tail))
((re-bol? elt) (values (+ pre-dsm tail-pre-dsm) cset
bos? eos? #t eol? bow? eow? tail))
((re-eol? elt) (values (+ pre-dsm tail-pre-dsm) cset
bos? eos? bol? #t bow? eow? tail))
((re-bow? elt) (values (+ pre-dsm tail-pre-dsm) cset
bos? eos? bol? eol? #t eow? tail))
((re-eow? elt) (values (+ pre-dsm tail-pre-dsm) cset
bos? eos? bol? eol? bow? #t tail))
(else (no-simp)))))))
(values 0 char-set:empty #f #f #f #f #f #f '()))))
(define (simp-repeat re)
(let ((from (re-repeat:from re))
(to (re-repeat:to re))
(body (re-repeat:body re)))
(receive (simp-body pre-dsm) (simp-re body) ; Simplify body.
;; The fancy reductions are all handled by REDUCE-REPEAT.
(reduce-repeat from to simp-body pre-dsm))))
;;; Does RE contain a live submatch?
;;; If RE is dynamic, we can't tell, so we err conservatively,
;;; which means we say "yes."
(define (has-live-submatches? re)
(or (re-submatch? re)
(? ((re-seq? re) (every has-live-submatches? (re-seq:elts re)))
((re-choice? re) (every has-live-submatches? (re-choice:elts re)))
((re-repeat? re) (has-live-submatches? (re-repeat:body re)))
((re-dsm? re) (has-live-submatches? (re-dsm:body re)))
;; If it's not one of these things, then this isn't a regexp -- it's
;; a chunk of Scheme code producing a regexp, and we conservatively
;; return #T -- the expression *might* produce a regexp containing
;; a live submatch:
(else (not (or (re-char-set? re) (re-string? re)
(re-bos? re) (re-eos? re)
(re-bol? re) (re-eol? re)
(re-bow? re) (re-eow? re)))))))