#!r6rs

(import (rename (rnrs)
                (get-line read-line)
                (call-with-string-output-port call-with-output-string))
        (srfi :78 lightweight-testing)
        (srfi :115 regexp))

;;; Shims to run the tests

(define (test-begin name) #f)

(define-syntax test
  (lambda (x)
    (syntax-case x ()
      ((_ x y)
       #'(guard (exn
                 (else
                  (display "Failed with exception: ")
                  (write 'x)
                  (newline)
                  (write (list (and (message-condition? exn) (condition-message exn))
                               (and (irritants-condition? exn) (condition-irritants exn))))
                  (newline)))
           (check x => y))))))

(define (test-end) #f)

;;; From regexp-test.sld. Replaced #u8( with #vu8(.

;; Copyright (c) 2009-2015 Alex Shinn
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. The name of the author may not be used to endorse or promote products
;;    derived from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(define (run-tests)
  (define (maybe-match->sexp rx str . o)
    (let ((res (apply regexp-matches rx str o)))
      (and res (regexp-match->sexp res))))

  (define-syntax test-re
    (syntax-rules ()
      ((test-re res rx str start end)
       (test res (maybe-match->sexp rx str start end)))
      ((test-re res rx str start)
       (test-re res rx str start (string-length str)))
      ((test-re res rx str)
       (test-re res rx str 0))))

  (define (maybe-search->sexp rx str . o)
    (let ((res (apply regexp-search rx str o)))
      (and res (regexp-match->sexp res))))

  (define-syntax test-re-search
    (syntax-rules ()
      ((test-re-search res rx str start end)
       (test res (maybe-search->sexp rx str start end)))
      ((test-re-search res rx str start)
       (test-re-search res rx str start (string-length str)))
      ((test-re-search res rx str)
       (test-re-search res rx str 0))))

  (test-begin "regexp")

  (test-re '("ababc" "abab")
           '(: ($ (* "ab")) "c")
           "ababc")

  (test-re '("ababc" "abab")
           '(: ($ (* "ab")) "c")
           "xababc"
           1)

  (test-re-search '("y") '(: "y") "xy")

  (test-re-search '("ababc" "abab")
                  '(: ($ (* "ab")) "c")
                  "xababc")

  (test-re #f
           '(: (* any) ($ "foo" (* any)) ($ "bar" (* any)))
           "fooxbafba")

  (test-re '("fooxbarfbar" "fooxbarf" "bar")
           '(: (* any) ($ "foo" (* any)) ($ "bar" (* any)))
           "fooxbarfbar")

  (test-re '("abcd" "abcd")
           '($ (* (or "ab" "cd")))
           "abcd")

  ;; first match is a list of ab's, second match is the last (temporary) cd
  (test-re '("abcdc" (("ab") ("cd")) "cd")
           '(: (* (*$ (or "ab" "cd"))) "c")
           "abcdc")

  (test "ab"
        (regexp-match-submatch
         (regexp-matches '(or (-> foo "ab") (-> foo "cd")) "ab")
         'foo))

  (test "cd"
        (regexp-match-submatch
         (regexp-matches '(or (-> foo "ab") (-> foo "cd")) "cd")
         'foo))

  ;; non-deterministic case from issue #229
  (let* ((elapsed '(: (** 1 2 num) ":" num num (? ":" num num)))
         (span (rx ,elapsed "-" ,elapsed)))
    (test-re-search '("1:45:02-2:06:13") span " 1:45:02-2:06:13 "))

  (test-re '("ababc" "abab")
           '(: bos ($ (* "ab")) "c")
           "ababc")
  (test-re '("ababc" "abab")
           '(: ($ (* "ab")) "c" eos)
           "ababc")
  (test-re '("ababc" "abab")
           '(: bos ($ (* "ab")) "c" eos)
           "ababc")
  (test-re #f
           '(: bos ($ (* "ab")) eos "c")
           "ababc")
  (test-re #f
           '(: ($ (* "ab")) bos "c" eos)
           "ababc")

  (test-re '("ababc" "abab")
           '(: bol ($ (* "ab")) "c")
           "ababc")
  (test-re '("ababc" "abab")
           '(: ($ (* "ab")) "c" eol)
           "ababc")
  (test-re '("ababc" "abab")
           '(: bol ($ (* "ab")) "c" eol)
           "ababc")
  (test-re #f
           '(: bol ($ (* "ab")) eol "c")
           "ababc")
  (test-re #f
           '(: ($ (* "ab")) bol "c" eol)
           "ababc")
  (test-re '("\nabc\n" "abc")
           '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline))
           "\nabc\n")
  (test-re #f
           '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline))
           "\n'abc\n")
  (test-re #f
           '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline))
           "\nabc.\n")

  (test-re '("ababc" "abab")
           '(: bow ($ (* "ab")) "c")
           "ababc")
  (test-re '("ababc" "abab")
           '(: ($ (* "ab")) "c" eow)
           "ababc")
  (test-re '("ababc" "abab")
           '(: bow ($ (* "ab")) "c" eow)
           "ababc")
  (test-re #f
           '(: bow ($ (* "ab")) eow "c")
           "ababc")
  (test-re #f
           '(: ($ (* "ab")) bow "c" eow)
           "ababc")
  (test-re '("  abc  " "abc")
           '(: (* space) bow ($ (* alpha)) eow (* space))
           "  abc  ")
  (test-re #f
           '(: (* space) bow ($ (* alpha)) eow (* space))
           " 'abc  ")
  (test-re #f
           '(: (* space) bow ($ (* alpha)) eow (* space))
           " abc.  ")
  (test-re '("abc  " "abc")
           '(: ($ (* alpha)) (* any))
           "abc  ")
  (test-re '("abc  " "")
           '(: ($ (*? alpha)) (* any))
           "abc  ")
  (test-re '("<em>Hello World</em>" "em>Hello World</em")
           '(: "<" ($ (* any)) ">" (* any))
           "<em>Hello World</em>")
  (test-re '("<em>Hello World</em>" "em")
           '(: "<" ($ (*? any)) ">" (* any))
           "<em>Hello World</em>")
  (test-re-search '("foo") '(: "foo") " foo ")
  (test-re-search #f '(: nwb "foo" nwb) " foo ")
  (test-re-search '("foo") '(: nwb "foo" nwb) "xfoox")

  (test-re '("beef")
           '(* (/"af"))
           "beef")

  (test-re '("12345beef" "beef")
           '(: (* digit) ($ (* (/"af"))))
           "12345beef")

  (let ((number '($ (+ digit))))
    (test '("555" "867" "5309")
          (cdr
           (regexp-match->list
            (regexp-search `(: ,number "-" ,number "-" ,number)
                           "555-867-5309"))))
    (test '("555" "5309")
          (cdr
           (regexp-match->list
            (regexp-search `(: ,number "-" (w/nocapture ,number) "-" ,number)
                           "555-867-5309")))))

  (test-re '("12345BeeF" "BeeF")
           '(: (* digit) (w/nocase ($ (* (/"af")))))
           "12345BeeF")

  (test-re #f '(* lower) "abcD")
  (test-re '("abcD") '(w/nocase (* lower)) "abcD")
  (test-re '("σζ") '(* lower) "σζ")
  (test-re '("Σ") '(* upper) "Σ")
  (test-re '("\x01C5;") '(* title) "\x01C5;")
  (test-re '("σζ\x01C5;") '(w/nocase (* lower)) "σζ\x01C5;")

  (test-re '("кириллица") '(* alpha) "кириллица")
  (test-re #f '(w/ascii (* alpha)) "кириллица")
  (test-re '("кириллица") '(w/nocase "КИРИЛЛИЦА") "кириллица")

  (test-re '("１２３４５") '(* digit) "１２３４５")
  (test-re #f '(w/ascii (* digit)) "１２３４５")

  (test-re '("한") 'grapheme "한")
  (test-re '("글") 'grapheme "글")

  (test-re '("한") '(: bog grapheme eog) "한")
  (test-re #f '(: "ᄒ" bog grapheme eog "ᆫ") "한")

  (test '("123" "456" "789") (regexp-extract '(+ digit) "abc123def456ghi789"))
  (test '("123" "456" "789") (regexp-extract '(* digit) "abc123def456ghi789"))
  (test '("abc" "def" "ghi" "") (regexp-split '(+ digit) "abc123def456ghi789"))
  (test '("abc" "def" "ghi" "")
        (regexp-split '(* digit) "abc123def456ghi789"))
  (test '("a" "b") (regexp-split '(+ whitespace) "a b"))
  (test '("a" "" "b")
        (regexp-split '(",;") "a,,b"))
  (test '("a" "" "b" "")
        (regexp-split '(",;") "a,,b,"))
  (test '("")
        (regexp-partition '(* digit) ""))
  (test '("abc" "123" "def" "456" "ghi")
        (regexp-partition '(* digit) "abc123def456ghi"))
  (test '("abc" "123" "def" "456" "ghi" "789")
        (regexp-partition '(* digit) "abc123def456ghi789"))

  (test '("한" "글")
        (regexp-extract
         'grapheme
         (utf8->string '#vu8(#xe1 #x84 #x92 #xe1 #x85 #xa1 #xe1 #x86 #xab
                                  #xe1 #x84 #x80 #xe1 #x85 #xb3 #xe1 #x86 #xaf))))

  (test "abc def" (regexp-replace '(+ space) "abc \t\n def" " "))
  (test "  abc-abc"
        (regexp-replace '(: ($ (+ alpha)) ":" (* space)) "  abc: " '(1 "-" 1)))
  (test "  abc-  abc"
        (regexp-replace '(: ($ (+ alpha)) ":" (* space)) "  abc: " '(1 "-" pre 1)))

  (test "-abc \t\n d ef  "
        (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0))
  (test "-abc \t\n d ef  "
        (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 0))
  (test "  abc-d ef  "
        (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 1))
  (test "  abc \t\n d-ef  "
        (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 2))
  (test "  abc \t\n d ef-"
        (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 3))
  (test "  abc \t\n d ef  "
        (regexp-replace '(+ space) "  abc \t\n d ef  " "-" 0 #f 4))
  (test " abc d ef " (regexp-replace-all '(+ space) "  abc \t\n d ef  " " "))

  ;; Disabled pcre tests.
  #;
  (let ()
    (define (subst-matches matches input subst)
      (define (submatch n)
        (regexp-match-submatch matches n))
      (and
        matches
        (call-with-output-string
         (lambda (out)
           (call-with-input-string subst
                                   (lambda (in)
                                     (let lp ()
                                       (let ((c (read-char in)))
                                         (cond
                                           ((not (eof-object? c))
                                            (case c
                                              ((#\&)
                                               (display (or (submatch 0) "") out))
                                              ((#\\)
                                               (let ((c (read-char in)))
                                                 (if (char-numeric? c)
                                                     (let lp ((res (list c)))
                                                       (if (and (char? (peek-char in))
                                                                (char-numeric? (peek-char in)))
                                                           (lp (cons (read-char in) res))
                                                           (display
                                                            (or (submatch (string->number
                                                                           (list->string (reverse res))))
                                                                "")
                                                            out)))
                                                     (write-char c out))))
                                              (else
                                               (write-char c out)))
                                            (lp)))))))))))

    (define (test-pcre line)
      (match (string-split line #\tab)
        ((pattern input result subst output)
         (let ((name (string-append pattern " " input " " result " " subst)))
           (cond
             ((equal? "c" result)
              (test-error name (regexp-search (pcre->sre pattern) input)))
             ((equal? "n" result)
              (test-assert name (not (regexp-search (pcre->sre pattern) input))))
             (else
              (test name output
                    (subst-matches (regexp-search (pcre->sre pattern) input)
                                   input
                                   subst))))))
        (else
         (error "invalid regex test line" line))))

    (test-group "pcre"
                (let ((in (open-input-file "tests/re-tests.txt")))
                  (let lp ()
                    (let ((line (read-line in)))
                      (unless (eof-object? line)
                        (test-pcre line)
                        (lp)))))))

  (test-end))

(run-tests)
