Commits

Moritz Heidkamp committed fa888c5

initial import

Comments (0)

Files changed (2)

coops-protocols.scm

+(module coops-protocols
+
+(<protocol> define-protocol extend-protocol
+ protocol-extenders extend-class class-extends?
+ satisfies?)
+
+(import chicken scheme)
+(use coops srfi-1)
+
+;; this is necessary due to a bug in coops, see ticket #478
+(begin-for-syntax
+ (import chicken)
+ (use srfi-1))
+
+(define-class <protocol> ()
+  ((specs)
+   (extenders initform: '() reader: protocol-extenders)))
+
+(define-syntax define-protocol
+  (syntax-rules ()
+    ((_ name
+        (spec (this args ...))
+        ...)
+     (begin
+       (define-generic (spec this))
+       ...
+       (define name
+         (make <protocol>
+           'specs
+           '((spec this args ...)
+             ...)))))))
+
+(define-syntax extend-class
+  (syntax-rules ()
+    ((_ class
+        (protocol
+         (spec (this args ...)
+               body ...)
+         ...)
+        ...)
+     (begin
+       (begin
+         (set! (slot-value protocol 'extenders)
+               (cons class (protocol-extenders protocol)))
+         (define-method (spec (this class) args ...) body ...)
+         ...)
+       ...))))
+
+(define-syntax extend-protocol
+  (syntax-rules ()
+    ((_ protocol
+        (class
+         (spec (this args ...)
+               body ...)
+         ...)
+        ...)
+     (begin
+       (extend-class
+        class
+        (protocol
+         (spec (this args ...)
+               body ...)
+         ...))
+       ...))))
+
+(define (class-extends? class protocol)
+  (any (lambda (extender)
+         (subclass? class extender))
+       (protocol-extenders protocol)))
+
+(define (satisfies? protocol object)
+  (let ((class (class-of object)))
+    (if (eq? #t class)
+        (error 'satisfies? "not a coops instance" object)
+        (class-extends? class protocol))))
+
+)
+(load-relative "../coops-protocols")
+(import coops-protocols)
+(use test)
+(use coops coops-primitive-objects srfi-13 data-structures)
+
+(define-protocol seq-access
+  (head (this))
+  (tail (this)))
+
+(define-protocol seq-mod
+  (prepend (this element)))
+
+(extend-class
+ <string>
+ (seq-access
+  (head
+   (this)
+   (string-ref this 0))
+  (tail
+   (this)
+   (string-drop this 1)))
+ (seq-mod
+  (prepend
+   (this el)
+   (string-append el this))))
+
+(extend-class
+ <list>
+ (seq-access
+  (head
+   (this)
+   (car this))
+  (tail
+   (this)
+   (cdr this)))
+ (seq-mod
+  (prepend
+   (this el)
+   (cons el this))))
+
+(extend-protocol
+ seq-access
+ (<vector>
+  (head (this)
+        (vector-ref this 0))
+  (tail (this)
+        (vector-copy this 1)))
+ (<queue>
+  (head (this)
+        (queue-first this))
+  (tail (this)
+        (cdr (queue->list this)))))
+
+
+(test-group "satisfies?"
+  (test-assert (satisfies? seq-access "foo"))
+  (test-assert (satisfies? seq-mod "bar"))
+  (test-assert (satisfies? seq-access '(1 2)))
+  (test-assert (satisfies? seq-mod '()))
+  (test-assert (not (satisfies? seq-mod display))))
+
+(test-group "class-extends?"
+  (test-assert (class-extends? <list> seq-access))
+  (test-assert (class-extends? <pair> seq-access)) ; <pair> is a subclass of <list>
+  (test-assert (not (class-extends? <char> seq-access)))
+  (test-assert (class-extends? <string> seq-mod))
+  (test-assert (class-extends? <queue> seq-access))
+  (test-assert (not (class-extends? <queue> seq-mod))))
+
+(test-group "protocol methods"
+  (test #\f (head "foo"))
+  (test 1 (head '(1 2 3)))
+  (test '(1 2 3) (prepend '(2 3) 1))
+  (test "abc" (prepend "bc" "a"))
+  (test 1 (head (vector 1 2 3))))