scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
scsh-0.6/scsh/test/pattern-matching-test.scm

314 lines
11 KiB
Scheme
Raw Normal View History

Log Message: first commit
2004-08-09 04:46:09 -04:00
;;; Test for the function in section 6 of the scsh-manual "Pattern-matching strings with regular expressions"
;;; Author: Christoph Hetz
;; for testing: (certainly the path will be an other on other systems...)
;; ,open define-record-types handle
;; ,config ,load C:/cygwin/home/mephisto/cvs-scsh/scsh/scsh/test/test-packages.scm
;; ,load C:/cygwin/home/mephisto/cvs-scsh/scsh/scsh/test/test-base.scm
;; load this file
;; (test-all)
;; *** basic help-functions ***
(define eq-match?
(lambda (m1 m2)
(and (= (match:start m1)
(match:start m2))
(= (match:end m1)
(match:end m2))
(equal? (match:substring m1)
(match:substring m2)))))
;; *** tests ***
(define test-string "Dieser Test-String wurde am 29.07.2004 um 5:23PM erstellt.\na aa aaa aaaa\nab aabb aaabbb\naba abba abbba\n1 12 123 1234\nyyyyyyyyyy\n")
(define nul-string (list->string (list (ascii->char 0) (ascii->char 0))))
(define newln-string "\n\n")
(add-test! 'no-match-test 'pattern-matching
(lambda ()
(not (string-match (rx "xxx") test-string))))
(add-test! 'simple-string-match 'pattern-matching
(lambda ()
(eq-match? (string-match (rx (- alpha ("aeiouAEIOU"))) test-string)
(string-match (rx (- (/"azAZ") ("aeiouAEIOU"))) test-string))))
(add-test! 'simple-string-regexp 'pattern-matching
(lambda ()
(and (equal? "erstellt."
(match:substring (string-match (rx "erstellt.") test-string)))
(not (string-match (rx "Erstellt.") test-string)))))
(add-test! 'simple-character-set 'pattern-matching
(lambda ()
(eq-match? (string-match (rx ("abcde")) test-string)
(string-match (rx ("edcba")) test-string))))
changed a few tests
2004-08-12 16:17:35 -04:00
(add-test! 'any-test 'pattern-matching ;; fails only because of the case i = 0
Log Message: first commit
2004-08-09 04:46:09 -04:00
(lambda ()
changed a few tests
2004-08-12 16:17:35 -04:00
(let loop ((i 0))
(if (= 256 i)
#t
(if (string-match (rx any) (list->string (list (ascii->char i))))
(loop (+ i 1))
#f)))))
Log Message: first commit
2004-08-09 04:46:09 -04:00
(add-test! 'sequences-test 'pattern-matching
(lambda ()
(equal? "1234"
(match:substring (string-match (rx (: "1" any any "4")) test-string)))))
(add-test! 'choices 'pattern-matching
(lambda ()
(let ((m1 (string-match (rx (| "erstellt." "xxx")) test-string))
(m2 (string-match (rx (| "xxx" "erstellt.")) test-string)))
(and m1
m2
(eq-match? m1 m2)))))
(add-test! '*-test 'pattern-matching
(lambda ()
(and (equal? ""
(match:substring (string-match (rx (* "y")) test-string)))
(equal? "D"
(match:substring (string-match (rx (* "D")) test-string))))))
(add-test! '+-test 'pattern-matching
(lambda ()
(and (equal? "yyyyyyyyyy"
(match:substring (string-match (rx (+ "y")) test-string)))
(equal? "D"
(match:substring (string-match (rx (+ "D")) test-string))))))
(add-test! '?-test 'pattern-matching
(lambda ()
(and (equal? ""
(match:substring (string-match (rx (? "y")) test-string)))
(equal? "D"
(match:substring (string-match (rx (? "D")) test-string))))))
(add-test! '=-from-test 'pattern-matching
(lambda ()
(and (equal? "yyyyy"
(match:substring (string-match (rx (= 5 "y")) test-string)))
(not (string-match (rx (= 11 "y")) test-string)))))
(add-test! '>=-from-test 'pattern-matching
(lambda ()
(and (equal? "yyyyyyyyyy"
(match:substring (string-match (rx (>= 5 "y")) test-string)))
(equal? "yyyyyyyyyy"
(match:substring (string-match (rx (>= 10 "y")) test-string)))
(not (string-match (rx (>= 11 "y")) test-string)))))
(add-test! '**from-to-test 'pattern-matching
(lambda ()
(and (equal? "yyyyyyyyyy"
(match:substring (string-match (rx (** 1 30 "y")) test-string)))
(equal? "yyyyy"
(match:substring (string-match (rx (** 1 5 "y")) test-string)))
(not (string-match (rx (** 11 12 "y")) test-string))
(not (string-match (rx (** 12 11 any)) test-string))
(equal? ""
(match:substring (string-match (rx (** 0 0 any)) test-string))))))
(add-test! 'single-characters-test 'pattern-matching
(lambda ()
(and (eq-match? (string-match (rx ("abcd")) test-string)
(string-match (rx (| #\a #\b #\c #\d)) test-string))
(eq-match? (string-match (rx ("xy")) test-string)
(string-match (rx (| #\x #\y)) test-string)))))
more test cases
2004-08-12 11:13:18 -04:00
(add-test! 'range-test 'pattern-matching
(lambda ()
(and (equal? "D"
(match:substring (string-match (rx (/ #\A #\Z #\a #\z #\0 #\9)) test-string)))
(equal? "D"
(match:substring (string-match (rx (/ #\A "Zaz0" #\9)) test-string)))
(equal? "i"
(match:substring (string-match (rx (/ #\a #\z #\0 #\9)) test-string)))
(equal? "i"
(match:substring (string-match (rx (/ #\a "z0" #\9)) test-string)))
(equal? "2"
(match:substring (string-match (rx (/ #\0 #\9)) test-string)))
(equal? "2"
(match:substring (string-match (rx (/ "0" #\9)) test-string))))))
(add-test! 'character-classes-test 'pattern-matching
(lambda ()
(and (eq-match? (string-match (rx lower-case) test-string)
(string-match (rx (- alphabetic upper-case)) test-string))
(eq-match? (string-match (rx upper-case) test-string)
(string-match (rx (- alphabetic lower-case)) test-string))
(equal? "2"
(match:substring (string-match (rx numeric) test-string)))
(equal? "-"
(match:substring (string-match (rx punctuation) test-string)))
(equal? " "
(match:substring (string-match (rx blank) test-string)))
(equal? " "
(match:substring (string-match (rx whitespace) test-string)))
(equal? "\n"
(match:substring (string-match (rx control) test-string)))
(equal? "D"
(match:substring (string-match (rx hex-digit) test-string)))
(equal? "D"
(match:substring (string-match (rx ascii) test-string))))))
(add-test! 'uncsae-w/case-w/nocase-test 'pattern-matching
(lambda ()
(and (equal? "foo"
(match:substring (string-match (rx (uncase "foo")) "bla foo bla")))
(equal? "FOO"
(match:substring (string-match (rx (uncase "foo")) "bla FOO bla")))
(equal? "FOo"
(match:substring (string-match (rx (uncase "foo")) "bla FOo bla")))
(equal? "fOo"
(match:substring (string-match (rx (uncase "foo")) "bla fOo bla")))
(equal? "FoO"
(match:substring (string-match (rx (uncase "foo")) "bla FoO bla")))
(equal? "a"
(match:substring (string-match (rx (uncase (~ "a"))) "a")))
(equal? "A"
(match:substring (string-match (rx (uncase (~ "a"))) "A")))
(not (string-match (rx (w/nocase (~ "a"))) "aA"))
(string-match (rx (w/nocase "abc"
(* "FOO" (w/case "Bar"))
("aeiou")))
"kabcfooBariou")
(not (string-match (rx (w/nocase "abc"
(* "FOO" (w/case "Bar"))
("aeiou")))
"kabcfooBARiou")))))
(add-test! 'dynamic-re-test-1 'pattern-matching
(lambda ()
(let ((str "I am feeding the goose, you are feeding the geese.")
(me 1)
(you 2))
(and (equal? "feeding the goose"
(match:substring (string-match (rx (: "feeding the "
,(if (> me 1) "geese" "goose")))
str)))
(equal? "feeding the geese"
(match:substring (string-match (rx (: "feeding the "
,(if (> you 1) "geese" "goose")))
str)))))))
(add-test! 'dynamic-re-test-2 'pattern-matching
(lambda ()
(let* ((ws (rx (+ whitespace)))
(date (rx (: (| "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul")
,ws
(| ("123456789")
(: ("12") digit)
"30"
"31")))))
(and (equal? "on Mar 14"
(match:substring (string-match (rx (: "on " ,date)) "it was on Mar 14 ...")))
(equal? "on May 31"
(match:substring (string-match (rx (: "on " ,date)) "it was on May 31 ...")))))))
(add-test! 'regexp?-test 'pattern-matching
(lambda ()
(and (not (regexp? "abc"))
(regexp? (rx "abc")))))
(add-test! 'regexp-search-test 'pattern-matching
(lambda ()
(and (equal? "abc"
(match:substring (regexp-search (rx "abc") "abcdefg")))
(not (regexp-search (rx "abc") "abcdefg" 3))
(not (regexp-search (rx "cba") "abcdefg")))))
(add-test! 'regexp-search?-test 'pattern-matching
(lambda ()
(and (regexp-search? (rx "abc") "abcdefg")
(not (regexp-search? (rx "abc") "abcdefg" 3))
(not (regexp-search? (rx "cba") "abcdefg")))))
(add-test! 'regexp-substitute/global-test-1 'pattern-matching
(lambda ()
(equal? "dry Jin"
(regexp-substitute/global #f (rx "Cotton") "dry Cotton"
'pre "Jin" 'post))))
(add-test! 'regexp-substitute/global-test-2 'pattern-matching
(lambda ()
(equal? "01/03/79"
(regexp-substitute/global #f (rx (submatch (+ digit)) "/"
(submatch (+ digit)) "/"
(submatch (+ digit)))
"03/01/79"
'pre 2 "/" 1 "/" 3 'post))))
(add-test! 'regexp-substitute/global-test-3 'pattern-matching
(lambda ()
(equal? "Sep 29, 1961"
(regexp-substitute/global #f (rx (submatch (+ digit)) "/"
(submatch (+ digit)) "/"
(submatch (+ digit)))
"9/29/61"
'pre
(lambda (m)
(let ((mon (vector-ref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun"
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
(- (string->number (match:substring m 1)) 1)))
(day (match:substring m 2))
(year (match:substring m 3)))
(string-append mon " " day ", 19" year)))
'post))))
(add-test! 'regexp-substitute/global-test-4 'pattern-matching
(lambda ()
(let ((kill-matches (lambda (re s)
(regexp-substitute/global #f re s 'pre 'post))))
(equal? " will disappear, also and "
(kill-matches (rx (| "Windows" "tcl" "Intel")) "Windows will disappear, also tcl and Intel")))))
(add-test! 'regexp-fold-right-test 'pattern-matching
(lambda ()
(equal? (list "1" "1" "2" "2")
(regexp-fold-right (rx digit)
(lambda (m i lis)
(cons (match:substring m 0) lis))
'() "a1 b1 a2 b2 ..."))))
(add-test! 'let-match-test 'pattern-matching
(lambda ()
(equal? "3/1/79\nmonth: 3\nday: 1\nyear: 79"
(let-match (regexp-search (rx (submatch (+ digit)) "/"
(submatch (+ digit)) "/"
(submatch (+ digit)))
"here comes a date: 3/1/79")
(whole-date month day year)
(string-append whole-date "\nmonth: " month "\nday: " day "\nyear: " year)))))
(add-test! 'sre->regexp-test 'pattern-matching
(lambda ()
(regexp? (sre->regexp '(: "Christoph " (? "F. ") "Hetz")))))
;;Warning: wrong number of arguments
;; (re-seq (re-string "Pete ") (re-repeat 1 #f (re-string "Sz")) (re-string "ilagyi"))
;; (procedure wants: (:value))
;; (arguments are: (:value :value :value))
;;
;;
;(add-test! 'regexp->sre-test 'pattern-matching
Log Message: first commit
2004-08-09 04:46:09 -04:00
; (lambda ()
more test cases
2004-08-12 11:13:18 -04:00
; (equal? '(? "Pete" (+ "Sz") "ilagyi")
; (regexp->sre (re-repeat 0 1 (re-seq (re-string "Pete ")
; (re-repeat 1 #f (re-string "Sz"))
; (re-string "ilagyi")))))))