From ba3b016c43969ab79f6f2b37335d156f69bfcb2b Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Thu, 1 Feb 2018 13:31:31 -0500 Subject: [PATCH] Cleanup, add both record type tests from docs --- tests/match-tests.scm | 106 ++++++------------------------------------ 1 file changed, 14 insertions(+), 92 deletions(-) diff --git a/tests/match-tests.scm b/tests/match-tests.scm index c87d4656..ab5ad50a 100644 --- a/tests/match-tests.scm +++ b/tests/match-tests.scm @@ -14,96 +14,8 @@ (chibi test))) ) -;; Temporary test section -;; #;(display -;; ;(match "test" ((? string? s) s) (else #f)) -;; ; -;; ;(let ((v "test")) -;; ; (match-next v ("test" (set! "test")) ((? string? s) s) (else #f))) -;; ; -;; ;(let ((v "test")) -;; ; (let ((failure (lambda () (match-next v ("test" (set! "test")) (else #f))))) -;; ; (match-one v ((? string? s) s) ("test" (set! "test")) (match-drop-ids (begin . s)) (failure) ()))) -;; ; -;; ;(let ((v "test")) -;; ; (let ((failure (lambda () (match-next v ("test" (set! "test")) (else #f))))) -;; ; (match-check-ellipsis -;; ; s -;; ; (match-extract-vars (? string? s) (match-gen-ellipsis v (? string? s) () ("test" (set! "test")) (match-drop-ids (begin . s)) (failure) ()) () ()) -;; ; (match-two v ((? string? s) s) ("test" (set! "test")) (match-drop-ids (begin . s)) (failure) ())))) -;; ; -;; ;(let ((v "test")) -;; ; (let ((failure (lambda () (match-next v ("test" (set! "test")) (else #f))))) -;; ; (match-check-ellipsis -;; ; s -;; ; (match-extract-vars (? string? s) (match-gen-ellipsis v (? string? s) () ("test" (set! "test")) (match-drop-ids (begin . s)) (failure) ()) () ()) -;; ; (match-two v ((? string? s) s) ("test" (set! "test")) (match-drop-ids (begin . s)) (failure) ())))) -;; ; -;; ;(let ((v "test")) -;; ; (let ((failure (lambda () (match-next v ("test" (set! "test")) (else #f))))) -;; ; (match-two v ((? string? s) s) ("test" (set! "test")) (match-drop-ids (begin . s)) (failure) ()))) -;; ; END expansions we are sure about, below is just WIP: -;; -;; ; (let ((v "test")) -;; ; (let ((failure (lambda () (match-next v ("test" (set! "test")) (else #f))))) -;; ; (if (string? v) -;; ; (match-one v (and s) ("test" (set! "test")) (match-drop-ids (begin s)) (failure) ()) -;; ; (failure)))) -;; -;; ;; Following two are broken when using "and" but if we replace "and" with "my-and" in -;; ;; the lib's match-two macro and recompile, the following both work here with "my-and". -;; ;; Something funny going on here... -;; ; (match-one "test" (and s) ("test" (set! "test")) (match-drop-ids (begin s)) (failure) ()) -;; ; (match 1 ((and x) x)) -;; (match-two 1 (and x) (1 (set! 1)) (match-drop-ids (begin x)) (begin) ()) -;; ; (match-two "test" ((? string? s) s) ("test" (set! "test")) (match-drop-ids (begin . s)) (begin) ()) -;; -;; ;; I think there is some kind of interaction going on here with the "and" macro, where it -;; ;; is being expanded even though it is part of the syntax-rules literals and should not be. -;; ;; Just a guess, need to prove it, but it could explain why we fall into this case even though -;; ;; pattern should have been (and p) - though not 100% sure, just a guess at this point -;; ; ((match-two v (p) g+s sk fk i) -;; ; (if (and (pair? v) (null? (cdr v))) -;; ; (let ((w (car v))) -;; ; (match-one w p ((car v) (set-car! v)) sk fk i)) -;; ; fk)) -;; -;; ) -;; -;; ;(expand (match "test" ((? string? s) s) (else #f)))*/ -;; ;(expand (match-two$171 v$1 (? string? s) ("test" (set! "test")) (match-drop-ids$9 (begin s)) (failure$5) ()))*/ -;; ;(expand (match-one$266 v$1 (and$262 s) ("test" (set! "test")) (match-drop-ids$9 (begin s)) (failure$5) ()))*/ -;; ;(expand (match-check-ellipsis$270 s (match-extract-vars$269 and$262 (match-gen-ellipsis$268 v$1 and$262 () ("test" (set! "test")) (match-drop-ids$9 (begin s)) (failure$5) ()) () ()) (match-two$267 v$1 (and$262 s) ("test" (set! "test")) (match-drop-ids$9 (begin s)) (failure$5) ())))*/ -;; ;(expand (match-two$267 v$1 (and$262 s) ("test" (set! "test")) (match-drop-ids$9 (begin s)) (failure$5) ()))*/ - -;;TODO: this does not work, try expanding it manually like we did with the other failing macros. maybe we can discover what's going wrong... -;; NOTE there is a warning in chibi on this one. maybe this is not a big deal -;(display (match 1 ((or x 2) x)) )(newline) -(display - (let () - (define-record-type employee - (make-employee name title) - employee? - (name get-name) - (title get-title)) - (match (make-employee "Bob" "Doctor") - (($ employee n t) (list t n)))) -) - -;; TODO: slot-ref needs to be extended to support this -#;(display - (let () - (define-record-type employee - (make-employee name title) - employee? - (name get-name) - (title get-title)) - (match (make-employee "Bob" "Doctor") - ((@ employee (title t) (name n)) (list t n)))) - ) - (test-group - "official tests" + "Official tests" (test 2 (match (list 1 2 3) ((a b c) b)) ) (test 2 (match (list 1 2 1) ((a a b) 1) ((a b a) 2))) @@ -154,6 +66,16 @@ (match (make-employee "Bob" "Doctor") (($ employee n t) (list t n))))) + (test '("Doctor" "Bob") + (let () + (define-record-type employee + (make-employee name title) + employee? + (name get-name) + (title get-title)) + (match (make-employee "Bob" "Doctor") + ((@ employee (title t) (name n)) (list t n))))) + (test '(1 . 3) (let ((x (cons 1 2))) (match x ((1 . (set! s)) (s 3) x)))) (test 2 (match '(1 . 2) ((1 . (get! g)) (g)))) (test '(a a a) (match '(a (a (a b))) ((x *** 'b) x))) @@ -161,8 +83,8 @@ ) -#;(test-group - "predicates" +(test-group + "Predicates" (test "test" (match "test" ((? string? s) s) (else #f))) (test #(fromlist 1 2) (match '(1 2) ((a b) (vector 'fromlist a b)))) @@ -190,7 +112,7 @@ )) (test-group - "example" + "Demo" (test (+ (* 5 60) 10) (calc-time '(5 min 10 sec))) (test (+ (* 24 60 60) (* 60 5) 10) (calc-time '(1 day 5 min 10 sec))) (test (+ (* 24 60 60) (* 60 60) (* 60 5) 10) (calc-time '(0 weeks 1 day 1 h 5 min 10 sec)))