; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2009,2010
; See the LICENSE file of the S9fES package for terms of use
;
; (re-comp string)              ==>  list
; (re-match list string)        ==>  list | #f
; (re-match list string 'lazy)  ==>  list | #f
;
; Compile and match regular expressions.
;
; RE-COMP compiles a regular expression (RE) and returns it.
; Compiled REs (CREs) are represented by lists.
;
; RE-MATCH matches a compiled RE against a string. When (part of) the
; string matches the CRE, it returns a list of the form
;
;       ((first limit) ...)
;
; where FIRST is the index of the first character matching the RE and
; LIMIT is the first character *after* the match (so the match can be
; extracted with SUBSTRING). When no submatches are used, just a list
; of the form ((first limit)) will be returned. When submatches using
; \( and \) are contained in the regular expression, the subsequent pairs
; will contain the ranges matched by the sub-expressions (in the order of
; sub-expressions in the RE). See examples.
;
; When the CRE does not match the string, RE-MATCH returns #F.
;
; A special case occurs when a given pattern may match a string of zero
; length. In this case, RE-MATCH returns () when no better match could
; be found.
;
; When 'LAZY is passed as the last argument to RE-MATCH, it matches
; repetitions lazily, e.g.: "A+" will match "A" (rather than "AAA")
; in "AAAB".
;
; The following RE patterns are evaluated:
; .          match any character
; [char...]  match character class (may contain ranges of the form c1-c2)
; ^          match beginning of line
; $          match end of line
; *          match zero or more instances of the preceding pattern
; +          match one or more instances of the preceding pattern
; ?          match the preceding pattern optionally
; \          match the following character literally (exception below!)
; \(         mark the beginning of a submatch
; \)         mark the end of a submatch
;
; Example:   (re-match (re-comp "^a[1-9]*z$") "a1289z")     ==>  ((0 6))
;            (re-match (re-comp "a[1-9]+z") "___a123z___")  ==>  ((3 8))
;            (re-match (re-comp "a[^1-9]+z") "a123z")       ==>  #f
;            (re-match (re-comp "[1-9]*") "__1__")          ==>  ((2 3))
;            (re-match (re-comp "[1-9]*") "_____")          ==>  ()
;            (re-match (re-comp "f\\(.\\)\\(.\\)bar")
;                      "foobar")                      ==>  ((0 6) (1 2) (2 3))

(define (re-comp re)

  (define LP   #\()
  (define RP   #\))

  (define (make-range c0 cn cls)
      (if (> c0 cn)
          cls
          (make-range (+ 1 c0)
                      cn
                      (cons (integer->char c0) cls))))

  (define (compile-class in out cls first)
    (cond ((null? in)
            #f)
          ((char=? #\] (car in))
            (list (cdr in) (cons (reverse cls) out)))
          ((and first (char=? #\^ (car in)))
            (compile-class (cdr in) out '(#\]) #f))
          ((and (not first)
                (not (null? (cdr cls)))
                (char=? #\- (car in))
                (pair? (cdr in))
                (not (char=? #\] (cadr in))))
            (let ((c0 (char->integer (car cls)))
                  (cn (char->integer (cadr in))))
              (if (< c0 cn)
                  (compile-class (cddr in)
                                 out
                                 (make-range c0 cn (cdr cls)) #f)
                  (compile-class (cdr in)
                                 out
                                 (cons #\- cls) #f))))
          (else
            (compile-class (cdr in)
                           out
                           (cons (car in) cls) #f))))

  (let compile ((in-sub #f)
                (in     (string->list re))
                (out    '()))
    (cond
      ((not in)
        #f)
      ((null? in)
        (if in-sub
            #f
            (reverse out)))
      (else
        (case (car in)
              ((#\\)
                (if (pair? (cdr in))
                    (if (memv (cadr in) '(#\( #\)))
                        (if (or (and      in-sub  (char=? LP (cadr in)))
                                (and (not in-sub) (char=? RP (cadr in))))
                            #f
                            (compile (char=? (cadr in) LP)
                                     (cddr in)
                                     (cons (list (cadr in)) out)))
                        (compile in-sub
                                 (cddr in)
                                 (cons (cadr in) out)))
                    #f))
              ((#\^ #\$ #\.)
                (compile in-sub
                         (cdr in)
                         (cons (list (car in)) out)))
              ((#\* #\?)
                (compile in-sub
                         (cdr in)
                         (if (null? out)
                             (cons (car in) out)
                             (cons (list (car in) (car out))
                                   (cdr out)))))
              ((#\+)
                (compile in-sub
                         (cdr in)
                         (if (null? out)
                             (cons (car in) out)
                             (cons (list #\* (car out)) out))))
              ((#\[)
                (apply compile
                       in-sub
                       (compile-class (cdr in) out '(#\[) #t)))
              (else
                (compile in-sub
                         (cdr in)
                         (cons (car in) out))))))))

(define (re-match cre s . opts)

  (define lazy #f)
  (define LP   #\()
  (define RP   #\))

  (define (match-char p c)
    (cond ((char? p)
            (char=? p c))
          ((char=? #\. (car p)))
          ((char=? #\[ (car p))
            (memv c (cdr p)))
          ((char=? #\] (car p))
            (not (memv c (cdr p))))
          (else
            #f)))

  (define (extend-match m n)
    (if (null? (car m))
        (list (list n 0))
        (cons (cons (+ 1 (caar m)) (cdar m)) (cdr m))))

  (define (make-choices cre s m)
    (if (or (null? s)
            (not (match-char (cadar cre) (car s))))
        (list (list s m))
        (cons (list s m)
              (make-choices cre (cdr s) (extend-match m 1)))))

  (define (begin-submatch m)
    `((,(caar m) ,(caar m)) ,(car m) ,@(cdr m)))

  (define (end-submatch m)
    (let ((sub  (car m))
          (main (cadr m)))
      `((,(car sub) ,(cadr main)) ,sub ,@(cddr m))))

  (define (match-cre cre s pos m)
    (cond
      ((null? cre)
        (map reverse m))
      ((null? s)
        (cond ((equal? cre '((#\$)))
                (match-cre '() '() pos m))
              ((and (pair? (car cre))
                    (char=? #\* (caar cre))
                    (null? (cdr cre)))
                '())
              (else
                #f)))
      ((pair? (car cre))
        (cond ((char=? LP (caar cre))
                (match-cre (cdr cre)
                           s
                           pos
                           (begin-submatch m)))
              ((char=? RP (caar cre))
                (match-cre (cdr cre)
                           s
                           pos
                           (end-submatch m)))
              ((char=? #\* (caar cre))
                (match-star cre s pos m))
              ((char=? #\? (caar cre))
                (if (match-char (cadar cre) (car s))
                    (match-cre (cdr cre)
                               (cdr s)
                               (+ 1 pos)
                               (extend-match m 1))
                    (match-cre (cdr cre) s pos m)))
              ((match-char (car cre) (car s))
                (match-cre (cdr cre)
                           (cdr s)
                           (+ 1 pos)
                           (extend-match m 1)))
              (else
                #f)))
      ((char=? (car cre) (car s))
        (match-cre (cdr cre)
                   (cdr s)
                   (+ 1 pos)
                   (extend-match m 1)))
      (else
        #f)))

  (define (match-star cre s pos m)
    (let try-choices ((c* (if lazy
                              (make-choices cre s m)
                              (reverse (make-choices cre s m)))))
      (and (not (null? c*))
           (let ((r (match-cre (cdr cre) (caar c*) pos (cadar c*))))
             (or r
                 (try-choices (cdr c*)))))))

  (define (adjust res pos)
    (and res
         (let ((res (map (lambda (range)
                           (map (lambda (x)
                                  (+ x pos))
                                range))
                         res)))
           `(,(car res) ,@(reverse (cdr res))))))

  (define (try-matches cre s pos)
    (cond ((null? s)
            (match-cre cre s pos '(())))
          (else
            (let ((r (match-cre cre s pos '(()))))
              (if (or (not r)
                      (null? r)
                      (and (pair? r)
                           (null? (car r))))
                  (try-matches cre (cdr s) (+ 1 pos))
                  (adjust r pos))))))

  (if (memq 'lazy opts)
      (set! lazy #t))

  (if (and (pair? cre)
           (equal? '(#\^) (car cre)))
      (adjust (match-cre (cdr cre) (string->list s) 0 '(())) 0)
      (try-matches cre (string->list s) 0)))
