|
|
@@ -0,0 +1,57 @@
|
|
|
+(import test)
|
|
|
+(import trait)
|
|
|
+
|
|
|
+(test-group "an Eq trait"
|
|
|
+ (define-trait Eq
|
|
|
+ (==)
|
|
|
+ (/= (lambda (a b) (not (== a b)))))
|
|
|
+
|
|
|
+ (define-trait-impl (Eq number?)
|
|
|
+ (== =))
|
|
|
+ (define-trait-impl (Eq symbol?)
|
|
|
+ (== eq?))
|
|
|
+
|
|
|
+ (test-assert (== 'a 'a))
|
|
|
+ (test-assert (not (/= 'a 'a)))
|
|
|
+
|
|
|
+ (test-assert (/= 'a 'b))
|
|
|
+ (test-assert (not (== 'a 'b)))
|
|
|
+
|
|
|
+ (test-assert (== 1 1))
|
|
|
+ (test-assert (not (/= 1 1)))
|
|
|
+
|
|
|
+ (test-assert (/= 1 2))
|
|
|
+ (test-assert (not (== 1 2))))
|
|
|
+
|
|
|
+(test-group "a Monad"
|
|
|
+ (define-trait Monad
|
|
|
+ (>>=)
|
|
|
+ (return))
|
|
|
+
|
|
|
+ (define-record nullable is-null value)
|
|
|
+ (define (make-some value)
|
|
|
+ (make-nullable #f value))
|
|
|
+ (define (make-null)
|
|
|
+ (make-nullable #t '()))
|
|
|
+ (define (nullable-type x)
|
|
|
+ (if (nullable-is-null x)
|
|
|
+ 'null
|
|
|
+ 'some))
|
|
|
+
|
|
|
+ (define-trait-impl (Monad nullable?)
|
|
|
+ (>>= (lambda (m f)
|
|
|
+ (let ((type (nullable-type m)))
|
|
|
+ (cond ((eq? type 'null)
|
|
|
+ (make-null))
|
|
|
+ ((eq? type 'some)
|
|
|
+ (f (nullable-value m)))))))
|
|
|
+ (return make-some))
|
|
|
+
|
|
|
+ (define (*2 a)
|
|
|
+ (make-some (* 2 a)))
|
|
|
+
|
|
|
+ (test-assert (= 6 (nullable-value (>>= (make-some 3) *2))))
|
|
|
+
|
|
|
+ (define x (make-some 42))
|
|
|
+ (let ((return (with-type-of x Monad return)))
|
|
|
+ (test-assert (= 99 (nullable-value (return 99))))))
|
