643 lines
20 KiB
Racket
643 lines
20 KiB
Racket
#lang scheme/base
|
|
|
|
(provide all-signature-tests)
|
|
|
|
(require rackunit
|
|
deinprogramm/define-record-procedures
|
|
deinprogramm/signature/signature
|
|
deinprogramm/signature/signature-german
|
|
deinprogramm/signature/signature-syntax)
|
|
|
|
(require scheme/promise)
|
|
|
|
(define integer (make-predicate-signature 'integer integer? 'integer-marker))
|
|
(define boolean (make-predicate-signature 'boolean boolean? 'boolean-marker))
|
|
(define %a (make-type-variable-signature 'a 'a-marker))
|
|
(define %b (make-type-variable-signature 'b 'b-marker))
|
|
|
|
(define-syntax say-no
|
|
(syntax-rules ()
|
|
((say-no ?body ...)
|
|
(let/ec exit
|
|
(call-with-signature-violation-proc
|
|
(lambda (obj signature message blame)
|
|
(exit 'no))
|
|
(lambda ()
|
|
?body ...))))))
|
|
|
|
(define-syntax failed-signature
|
|
(syntax-rules ()
|
|
((say-no ?body ...)
|
|
(let/ec exit
|
|
(call-with-signature-violation-proc
|
|
(lambda (obj signature message blame)
|
|
(exit signature))
|
|
(lambda ()
|
|
?body ...))))))
|
|
|
|
(define signature-tests
|
|
(test-suite
|
|
"Tests for signature combinators"
|
|
|
|
(test-case
|
|
"flat"
|
|
(check-equal? (say-no (apply-signature integer 5)) 5)
|
|
(check-equal? (say-no (apply-signature integer "foo")) 'no))
|
|
|
|
(test-case
|
|
"list"
|
|
(define integer-list (make-list-signature 'integer-list integer #f))
|
|
(check-equal? (say-no (apply-signature integer-list '(1 2 3)))
|
|
'(1 2 3))
|
|
(check-equal? (say-no (apply-signature integer-list '#f))
|
|
'no)
|
|
(check-eq? (failed-signature (apply-signature integer-list '(1 #f 3)))
|
|
integer))
|
|
|
|
(test-case
|
|
"list-cached"
|
|
(define integer-list (make-list-signature 'integer-list integer #f))
|
|
(define boolean-list (make-list-signature 'integer-list boolean #f))
|
|
(define l '(1 2 3))
|
|
(define foo "foo")
|
|
(define no '(1 #f 3))
|
|
(define no2 '(1 #f 3))
|
|
(define integer-list->bool (make-procedure-signature 'integer-list->bool (list integer-list) boolean 'int->bool-marker))
|
|
|
|
(check-equal? (say-no (apply-signature integer-list l))
|
|
'(1 2 3))
|
|
(check-equal? (say-no (apply-signature integer-list l))
|
|
'(1 2 3))
|
|
(check-equal? (say-no (apply-signature boolean-list l))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature integer-list foo))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature integer-list foo))
|
|
'no)
|
|
(check-eq? (failed-signature (apply-signature integer-list no))
|
|
integer)
|
|
(check-eq? (failed-signature (apply-signature integer-list no))
|
|
integer)
|
|
|
|
(let ((proc (say-no (apply-signature integer-list->bool (lambda (l) (even? (car l)))))))
|
|
(check-equal? (say-no (proc no)) 'no)
|
|
(check-equal? (say-no (proc no)) 'no)
|
|
(check-equal? (say-no (proc no2)) 'no)
|
|
(check-equal? (say-no (proc no2)) 'no))
|
|
)
|
|
|
|
(test-case
|
|
"vector"
|
|
(define integer-vector (make-vector-signature 'integer-list integer #f))
|
|
(check-equal? (say-no (apply-signature integer-vector '#(1 2 3)))
|
|
'#(1 2 3))
|
|
(check-equal? (say-no (apply-signature integer-vector '#f))
|
|
'no)
|
|
(check-eq? (failed-signature (apply-signature integer-vector '#(1 #f 3)))
|
|
integer))
|
|
|
|
(test-case
|
|
"vector/cached"
|
|
(let ((count 0))
|
|
(define counting-integer
|
|
(make-predicate-signature 'counting-integer
|
|
(lambda (obj)
|
|
(set! count (+ 1 count))
|
|
(integer? obj))
|
|
'integer-marker))
|
|
|
|
(define integer-vector (make-vector-signature 'integer-list counting-integer #f))
|
|
|
|
(define v1 '#(1 2 3))
|
|
|
|
(check-eq? (say-no (apply-signature integer-vector v1))
|
|
v1)
|
|
(check-equal? count 3)
|
|
(check-eq? (say-no (apply-signature integer-vector v1))
|
|
v1)
|
|
(check-equal? count 3)))
|
|
|
|
|
|
(test-case
|
|
"mixed"
|
|
(define int-or-bool (make-mixed-signature 'int-or-bool
|
|
(list integer
|
|
boolean)
|
|
'int-or-bool-marker))
|
|
(check-equal? (say-no (apply-signature int-or-bool #f))
|
|
#f)
|
|
(check-equal? (say-no (apply-signature int-or-bool 17))
|
|
17)
|
|
(check-equal? (say-no (apply-signature int-or-bool "foo"))
|
|
'no))
|
|
|
|
(test-case
|
|
"combined"
|
|
(define octet (make-combined-signature
|
|
'octet
|
|
(list
|
|
integer
|
|
(make-predicate-signature '<256
|
|
(delay (lambda (x)
|
|
(< x 256)))
|
|
'<256-marker)
|
|
(make-predicate-signature 'non-negative
|
|
(delay (lambda (x)
|
|
(>= x 0)))
|
|
'non-negative-marker))
|
|
'octet-marker))
|
|
(check-equal? (say-no (apply-signature octet #f))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature octet 17))
|
|
17)
|
|
(check-equal? (say-no (apply-signature octet 0))
|
|
0)
|
|
(check-equal? (say-no (apply-signature octet -1))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature octet 255))
|
|
255)
|
|
(check-equal? (say-no (apply-signature octet 256))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature octet "foo"))
|
|
'no))
|
|
|
|
(test-case
|
|
"case"
|
|
(define foo-or-bar (make-case-signature 'foo-or-bar '("foo" "bar") equal? 'foo-or-bar-marker))
|
|
(check-equal? (say-no (apply-signature foo-or-bar #f))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature foo-or-bar "foo"))
|
|
"foo")
|
|
(check-equal? (say-no (apply-signature foo-or-bar "bar"))
|
|
"bar"))
|
|
|
|
(test-case
|
|
"procedure"
|
|
(define int->bool (make-procedure-signature 'int->bool (list integer) boolean 'int->bool-marker))
|
|
(check-equal? (say-no (apply-signature int->bool #f))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature int->bool (lambda () "foo")))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature int->bool (lambda (x y) "foo")))
|
|
'no)
|
|
(let ((proc (say-no (apply-signature int->bool (lambda (x) (odd? x))))))
|
|
(check-pred procedure? proc)
|
|
(check-equal? (proc 15) #t)
|
|
(check-equal? (proc 16) #f)
|
|
(check-equal? (say-no (proc "foo")) 'no))
|
|
(let ((proc (say-no (apply-signature int->bool (lambda (x) (+ x 1))))))
|
|
(check-equal? (say-no (proc 12)) 'no)))
|
|
|
|
(test-case
|
|
"type variable - simple"
|
|
(check-equal? (say-no (apply-signature %a #f)) #f)
|
|
(check-equal? (say-no (apply-signature %a 15)) 15))
|
|
|
|
(test-case
|
|
"type variable - list"
|
|
(define a-list (make-list-signature 'a-list %a #f))
|
|
(check-equal? (say-no (apply-signature a-list '(1 2 3)))
|
|
'(1 2 3))
|
|
(check-equal? (say-no (apply-signature a-list '#f))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature a-list '(#f "foo" 5)))
|
|
'(#f "foo" 5)))
|
|
|
|
(test-case
|
|
"apply-signature/blame"
|
|
(define int->bool (make-procedure-signature 'int->bool (list integer) boolean 'int->bool-marker))
|
|
(let ((proc (say-no (apply-signature/blame int->bool (lambda (x) (odd? x))))))
|
|
(check-pred procedure? proc)
|
|
(check-equal? (proc 15) #t)
|
|
(check-equal? (proc 16) #f)
|
|
(check-equal? (say-no (proc "foo")) 'no))
|
|
(let ((proc (say-no (apply-signature/blame int->bool (lambda (x) x)))))
|
|
(call-with-signature-violation-proc
|
|
(lambda (obj signature message blame)
|
|
(check-true (syntax? blame)))
|
|
(lambda ()
|
|
(proc 5)))))
|
|
))
|
|
|
|
(define signature-syntax-tests
|
|
(test-suite
|
|
"Tests for signature syntax"
|
|
|
|
(test-case
|
|
"predicate"
|
|
(define integer (signature (predicate integer?)))
|
|
(check-equal? (say-no (apply-signature integer 5)) 5)
|
|
(check-equal? (say-no (apply-signature integer "foo")) 'no))
|
|
|
|
(test-case
|
|
"list"
|
|
(check-equal? (say-no (apply-signature (signature x (list-of %a)) 5)) 'no)
|
|
(check-equal? (say-no (apply-signature (signature x (list-of %a)) '(1 2 3))) '(1 2 3))
|
|
(check-equal? (say-no (apply-signature (signature x (list-of (predicate integer?))) '(1 2 3))) '(1 2 3))
|
|
(check-equal? (say-no (apply-signature (signature x (list-of (predicate integer?))) '(1 #f 3))) 'no))
|
|
|
|
(test-case
|
|
"mixed"
|
|
(define int-or-bool (signature (mixed integer boolean)))
|
|
(check-equal? (say-no (apply-signature int-or-bool #f))
|
|
#f)
|
|
(check-equal? (say-no (apply-signature int-or-bool 17))
|
|
17)
|
|
(check-equal? (say-no (apply-signature int-or-bool "foo"))
|
|
'no))
|
|
|
|
(test-case
|
|
"combined"
|
|
(define octet (signature (combined integer
|
|
(predicate (lambda (x)
|
|
(< x 256)))
|
|
(predicate (lambda (x)
|
|
(>= x 0))))))
|
|
(check-equal? (say-no (apply-signature octet #f))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature octet 17))
|
|
17)
|
|
(check-equal? (say-no (apply-signature octet 0))
|
|
0)
|
|
(check-equal? (say-no (apply-signature octet -1))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature octet 255))
|
|
255)
|
|
(check-equal? (say-no (apply-signature octet 256))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature octet "foo"))
|
|
'no))
|
|
|
|
(test-case
|
|
"procedure"
|
|
(define int->bool (signature int->bool ((predicate integer?) -> (predicate boolean?))))
|
|
(check-equal? (say-no (apply-signature int->bool #f))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature int->bool (lambda () "foo")))
|
|
'no)
|
|
(check-equal? (say-no (apply-signature int->bool (lambda (x y) "foo")))
|
|
'no)
|
|
(let ((proc (say-no (apply-signature int->bool (lambda (x) (odd? x))))))
|
|
(check-pred procedure? proc)
|
|
(check-equal? (proc 15) #t)
|
|
(check-equal? (proc 16) #f)
|
|
(check-equal? (say-no (proc "foo")) 'no))
|
|
(let ((proc (say-no (apply-signature int->bool (lambda (x) (+ x 1))))))
|
|
(check-equal? (say-no (proc 12)) 'no)))
|
|
|
|
|
|
(test-case
|
|
"record-wrap"
|
|
(define-record-procedures-parametric pare pare-of kons pare? (kar kdr))
|
|
(define ctr (pare-of integer boolean))
|
|
(let ((obj (apply-signature ctr (kons 1 #t))))
|
|
(check-equal? (kar obj) 1)
|
|
(check-equal? (kdr obj) #t))
|
|
(check-equal? (say-no (apply-signature ctr (kons 1 2))) 'no)
|
|
)
|
|
|
|
(test-case
|
|
"record-wrap/lazy"
|
|
(define-struct pare (kar kdr extra)
|
|
#:mutable
|
|
#:property prop:lazy-wrap
|
|
(make-lazy-wrap-info
|
|
(lambda (kar kdr) (kons kar kdr))
|
|
(list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x)))
|
|
(list (lambda (x v) (set-pare-kar! x v))
|
|
(lambda (x v) (set-pare-kdr! x v)))
|
|
(lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v))))
|
|
(define (kons kar kdr)
|
|
(make-pare kar kdr #f))
|
|
(define (kar p)
|
|
(check-lazy-wraps! struct:pare p)
|
|
(pare-kar p))
|
|
(define (kdr p)
|
|
(check-lazy-wraps! struct:pare p)
|
|
(pare-kdr p))
|
|
(define (pare-of kar-sig kdr-sig)
|
|
(make-lazy-wrap-signature 'pare #f
|
|
struct:pare
|
|
pare?
|
|
(list kar-sig kdr-sig)
|
|
#f))
|
|
(define ctr (pare-of integer boolean))
|
|
(let ((obj (apply-signature ctr (kons 1 #t))))
|
|
(check-equal? (kar obj) 1)
|
|
(check-equal? (kdr obj) #t))
|
|
(let ((obj (apply-signature ctr (kons 1 2))))
|
|
(check-equal? (say-no (kar obj)) 'no))
|
|
)
|
|
|
|
(test-case
|
|
"record-wrap-2"
|
|
(let ((count 0))
|
|
(define counting-integer
|
|
(make-predicate-signature 'counting-integer
|
|
(lambda (obj)
|
|
(set! count (+ 1 count))
|
|
(integer? obj))
|
|
'integer-marker))
|
|
(define-record-procedures-parametric pare pare-of kons pare? (kar kdr))
|
|
(define ctr (signature (pare-of counting-integer boolean)))
|
|
(let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t)))))
|
|
(check-equal? count 1)
|
|
(check-equal? (kar obj) 1)
|
|
(check-equal? count 1)
|
|
(check-equal? (kdr obj) #t)
|
|
(check-equal? count 1))))
|
|
|
|
(test-case
|
|
"record-wrap-2/lazy"
|
|
(let ((count 0))
|
|
(define counting-integer
|
|
(make-predicate-signature 'counting-integer
|
|
(lambda (obj)
|
|
(set! count (+ 1 count))
|
|
(integer? obj))
|
|
'integer-marker))
|
|
|
|
(define-struct pare (kar kdr extra)
|
|
#:mutable
|
|
#:property prop:lazy-wrap
|
|
(make-lazy-wrap-info
|
|
(lambda (kar kdr) (kons kar kdr))
|
|
(list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x)))
|
|
(list (lambda (x v) (set-pare-kar! x v))
|
|
(lambda (x v) (set-pare-kdr! x v)))
|
|
(lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v))))
|
|
(define (kons kar kdr)
|
|
(make-pare kar kdr #f))
|
|
(define (kar p)
|
|
(check-lazy-wraps! struct:pare p)
|
|
(pare-kar p))
|
|
(define (kdr p)
|
|
(check-lazy-wraps! struct:pare p)
|
|
(pare-kdr p))
|
|
(define (pare-of kar-sig kdr-sig)
|
|
(make-lazy-wrap-signature 'pare #f
|
|
struct:pare
|
|
pare?
|
|
(list kar-sig kdr-sig)
|
|
#f))
|
|
|
|
(define ctr (signature (pare-of counting-integer boolean)))
|
|
(let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t)))))
|
|
(check-equal? count 0)
|
|
(check-equal? (kar obj) 1)
|
|
(check-equal? count 1)
|
|
(check-equal? (kdr obj) #t)
|
|
(check-equal? count 1))))
|
|
|
|
(test-case
|
|
"record-wrap-3"
|
|
(let ((count 0))
|
|
(define counting-integer
|
|
(make-predicate-signature 'counting-integer
|
|
(lambda (obj)
|
|
(set! count (+ 1 count))
|
|
(integer? obj))
|
|
'integer-marker))
|
|
|
|
(define-record-procedures-parametric pare pare-of kons pare? (kar kdr))
|
|
(define ctr (signature (pare-of counting-integer boolean)))
|
|
(let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t)))))
|
|
(check-equal? count 1)
|
|
(check-equal? (kar obj) 1)
|
|
(check-equal? count 1)
|
|
(check-equal? (kdr obj) #t)
|
|
(check-equal? count 1)
|
|
;; after checking, the system should remember that it did so
|
|
(let ((obj-2 (apply-signature ctr obj)))
|
|
(check-equal? count 1)
|
|
(check-equal? (kar obj) 1)
|
|
(check-equal? count 1)
|
|
(check-equal? (kdr obj) #t)
|
|
(check-equal? count 1)))))
|
|
|
|
(test-case
|
|
"record-wrap-3/lazy"
|
|
(let ((count 0))
|
|
(define counting-integer
|
|
(make-predicate-signature 'counting-integer
|
|
(lambda (obj)
|
|
(set! count (+ 1 count))
|
|
(integer? obj))
|
|
'integer-marker))
|
|
(define-struct pare (kar kdr extra)
|
|
#:mutable
|
|
#:property prop:lazy-wrap
|
|
(make-lazy-wrap-info
|
|
(lambda (kar kdr) (kons kar kdr))
|
|
(list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x)))
|
|
(list (lambda (x v) (set-pare-kar! x v))
|
|
(lambda (x v) (set-pare-kdr! x v)))
|
|
(lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v))))
|
|
(define (kons kar kdr)
|
|
(make-pare kar kdr #f))
|
|
(define (kar p)
|
|
(check-lazy-wraps! struct:pare p)
|
|
(pare-kar p))
|
|
(define (kdr p)
|
|
(check-lazy-wraps! struct:pare p)
|
|
(pare-kdr p))
|
|
(define (pare-of kar-sig kdr-sig)
|
|
(make-lazy-wrap-signature 'pare #f
|
|
struct:pare
|
|
pare?
|
|
(list kar-sig kdr-sig)
|
|
#f))
|
|
|
|
(define ctr (signature (pare-of counting-integer boolean)))
|
|
(let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t)))))
|
|
(check-equal? count 0)
|
|
(check-equal? (kar obj) 1)
|
|
(check-equal? count 1)
|
|
(check-equal? (kdr obj) #t)
|
|
(check-equal? count 1)
|
|
;; after checking, the system should remember that it did so
|
|
(let ((obj-2 (apply-signature ctr obj)))
|
|
(check-equal? count 1)
|
|
(check-equal? (kar obj) 1)
|
|
(check-equal? count 1)
|
|
(check-equal? (kdr obj) #t)
|
|
(check-equal? count 1)))))
|
|
|
|
(test-case
|
|
"double-wrap"
|
|
(let ((count 0))
|
|
(define counting-integer
|
|
(make-predicate-signature 'counting-integer
|
|
(lambda (obj)
|
|
(set! count (+ 1 count))
|
|
(integer? obj))
|
|
'integer-marker))
|
|
(define-record-procedures-parametric pare pare-of raw-kons pare? (kar kdr))
|
|
|
|
(define empty-list (signature (predicate null?)))
|
|
|
|
(define my-list-of
|
|
(lambda (x)
|
|
(signature (mixed empty-list
|
|
(pare-of x (my-list-of x))))))
|
|
|
|
(define/signature kons (signature (%a (my-list-of %a) -> (pare-of %a (my-list-of %a))))
|
|
raw-kons)
|
|
|
|
(define/signature build-list (signature (integer -> (my-list-of counting-integer)))
|
|
(lambda (n)
|
|
(if (= n 0)
|
|
'()
|
|
(kons n (build-list (- n 1))))))
|
|
|
|
(define/signature list-length (signature ((my-list-of counting-integer) -> integer))
|
|
(lambda (lis)
|
|
(cond
|
|
((null? lis) 0)
|
|
((pare? lis)
|
|
(+ 1 (list-length (kdr lis)))))))
|
|
|
|
;; one wrap each for (my-list-of %a), one for (my-list-of counting-integer)
|
|
(let ((l1 (build-list 10)))
|
|
(check-equal? count 10)
|
|
(let ((len1 (list-length l1)))
|
|
(check-equal? count 10)))))
|
|
|
|
(test-case
|
|
"double-wrap/lazy"
|
|
(let ((count 0))
|
|
(define counting-integer
|
|
(make-predicate-signature 'counting-integer
|
|
(lambda (obj)
|
|
(set! count (+ 1 count))
|
|
(integer? obj))
|
|
'integer-marker))
|
|
|
|
(define-struct pare (kar kdr extra)
|
|
#:mutable
|
|
#:property prop:lazy-wrap
|
|
(make-lazy-wrap-info
|
|
(lambda (kar kdr) (raw-kons kar kdr))
|
|
(list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x)))
|
|
(list (lambda (x v) (set-pare-kar! x v))
|
|
(lambda (x v) (set-pare-kdr! x v)))
|
|
(lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v))))
|
|
(define (raw-kons kar kdr)
|
|
(make-pare kar kdr #f))
|
|
(define (kar p)
|
|
(check-lazy-wraps! struct:pare p)
|
|
(pare-kar p))
|
|
(define (kdr p)
|
|
(check-lazy-wraps! struct:pare p)
|
|
(pare-kdr p))
|
|
(define (pare-of kar-sig kdr-sig)
|
|
(make-lazy-wrap-signature 'pare #f
|
|
struct:pare
|
|
pare?
|
|
(list kar-sig kdr-sig)
|
|
#f))
|
|
|
|
|
|
(define empty-list (signature (predicate null?)))
|
|
|
|
(define my-list-of
|
|
(lambda (x)
|
|
(signature (mixed empty-list
|
|
(pare-of x (my-list-of x))))))
|
|
|
|
(define/signature kons (signature (%a (my-list-of %a) -> (pare-of %a (my-list-of %a))))
|
|
raw-kons)
|
|
|
|
(define/signature build-list (signature (integer -> (my-list-of counting-integer)))
|
|
(lambda (n)
|
|
(if (= n 0)
|
|
'()
|
|
(kons n (build-list (- n 1))))))
|
|
|
|
(define/signature list-length (signature ((my-list-of counting-integer) -> integer))
|
|
(lambda (lis)
|
|
(cond
|
|
((null? lis) 0)
|
|
((pare? lis)
|
|
(+ 1 (list-length (kdr lis)))))))
|
|
|
|
;; one wrap each for (my-list-of %a), one for (my-list-of counting-integer)
|
|
(let ((l1 (build-list 10)))
|
|
(check-equal? count 0)
|
|
(let ((len1 (list-length l1)))
|
|
(check-equal? count 10)))))
|
|
|
|
(test-case
|
|
"mixed wrap"
|
|
|
|
(define-struct pare (kar kdr extra)
|
|
#:mutable
|
|
#:property prop:lazy-wrap
|
|
(make-lazy-wrap-info
|
|
(lambda (kar kdr) (raw-kons kar kdr))
|
|
(list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x)))
|
|
(list (lambda (x v) (set-pare-kar! x v))
|
|
(lambda (x v) (set-pare-kdr! x v)))
|
|
(lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v))))
|
|
(define (raw-kons kar kdr)
|
|
(make-pare kar kdr #f))
|
|
(define (kar p)
|
|
(check-lazy-wraps! struct:pare p)
|
|
(pare-kar p))
|
|
(define (kdr p)
|
|
(check-lazy-wraps! struct:pare p)
|
|
(pare-kdr p))
|
|
(define (pare-of kar-sig kdr-sig)
|
|
(make-lazy-wrap-signature 'pare #f
|
|
struct:pare
|
|
pare?
|
|
(list kar-sig kdr-sig)
|
|
#f))
|
|
|
|
|
|
(define sig1 (signature (pare-of integer boolean)))
|
|
(define sig2 (signature (pare-of boolean integer)))
|
|
(define sig (signature (mixed sig1 sig2)))
|
|
(define/signature x sig (raw-kons #t 15))
|
|
(define/signature y sig (raw-kons #t #t))
|
|
(check-equal? (kar x) #t)
|
|
(check-equal? (say-no (kar y)) 'no))
|
|
|
|
(test-case
|
|
"wrap equality"
|
|
(define-record-procedures-parametric pare pare-of raw-kons pare? (kar kdr))
|
|
|
|
(define empty-list (signature (predicate null?)))
|
|
|
|
(define my-list-of
|
|
(lambda (x)
|
|
(signature (mixed empty-list
|
|
(pare-of x (my-list-of x))))))
|
|
|
|
(define/signature kons (signature (%a (my-list-of %a) -> (pare-of %a (my-list-of %a))))
|
|
raw-kons)
|
|
|
|
(check-equal? (raw-kons 1 '()) (raw-kons 1 '()))
|
|
(check-equal? (kons 1 '()) (kons 1 '()))
|
|
(check-equal? (kons 1 '()) (raw-kons 1 '()))
|
|
(check-equal? (raw-kons 1 '()) (kons 1 '())))
|
|
|
|
(test-case
|
|
"pair-wrap"
|
|
(define sig (make-pair-signature #f integer boolean))
|
|
(let ((obj (apply-signature sig (cons 1 #t))))
|
|
(check-equal? (checked-car obj) 1)
|
|
(check-equal? (checked-cdr obj) #t))
|
|
(let ((obj (apply-signature sig (cons 1 2))))
|
|
(check-equal? (say-no (checked-car obj)) 'no))
|
|
)
|
|
|
|
))
|
|
|
|
|
|
(define all-signature-tests
|
|
(test-suite
|
|
"all-signature-tests"
|
|
signature-tests
|
|
signature-syntax-tests))
|