protocol.scm

; = class system =

(define-library (picrin class)
  (import (scheme base))

  (define-record-type class-type
      (make-class membership)
      class?
    (membership class-membership))

  (define-syntax define-class
    (syntax-rules ()
      ((define-class name membership)
       (define name (make-class membership)))))

  (define (instance? obj class)
    ((class-membership class) obj))

  (define-class <class> class?)

  (define-class <any> (lambda (x) #t))
  (define-class <list> list?)
  (define-class <procedure> procedure?)
  (define-class <number> number?)
  (define-class <boolean> boolean?)
  (define-class <string> string?)

  (export make-class
          instance?
          define-class
          <class>
          <any>
          <list>
          <procedure>
          <number>
          <boolean>
          <string>))

; = protocol system =

(define-library (picrin protocol)
  (import (scheme base)
          (srfi 1))

  (import (picrin test)
          (picrin class))

  (define method-table
    '())

  (define (applicative? args types)
    (cond
     ((and (null? args) (null? types))
      #true)
     ((and (pair? args) (pair? types))
      (and (instance? (car args) (car types)) (applicative? (cdr args) (cdr types))))
     (else
      #false)))

  (test (applicative? '(1 2 ()) (list <number> <number> <list>)) #t)
  (test (applicative? '(1 () 2) (list <number> <number> <number>)) #f)
  (test (applicative? '(1 2 ()) (list <number> <number>)) #f)

  (define (find-generic generic)
    (or (assq generic method-table)
        (error "no method alist found")))

  (define (find-method generic args)
    (let ((methods (cdr (find-generic generic))))
      (let ((m (filter (lambda (x) (applicative? args (cdr x))) methods)))
        (if (null? m)
            #f
            (car (car m))))))

  (define (add-generic generic)
    (set! method-table (cons (cons generic '()) method-table)))

  (define (add-method generic method types)
    (let ((r (find-generic generic)))
      (set-cdr! r (cons (cons method types) (cdr r)))))

  (define (add-methods methods prototypes)
    (for-each
     (lambda (method prototype)
       (add-method (car prototype) method (cdr prototype)))
     methods
     prototypes))

  (define make-generic
    (lambda ()
      (letrec ((self (lambda args
                       (let ((m (find-method self args)))
                         (if m
                             (apply m args)
                             (error "method not found"))))))
        (add-generic self)
        self)))

  (define-syntax define-protocol
    (syntax-rules ()
      ((define-protocol (name type ...) (method arg ...) ...)
       (begin
         (define method
           (make-generic))
         ...
         (define name
           (lambda (type ...)
             (lambda methods
               (add-methods methods (list (list method arg ...) ...)))))))))

  (define-syntax define-instance
    (syntax-rules ()
      ((define-instance (name arg ...) method ...)
       ((name arg ...) method ...))))

  (export define-protocol
          define-instance))

(import (picrin class)
        (picrin protocol))

; show

(define-protocol (SHOW t)
  (show t))

(define-instance (SHOW <boolean>)
  (lambda (x)
    (if x
        "#true"
        "#false")))

(define-instance (SHOW <number>)
  number->string)

(define-instance (SHOW <list>)
  (lambda (x)
    (if (null? x)
        "()"
        (string-append "(" (show (car x)) " . " (show (cdr x)) ")"))))

(define-instance (SHOW <string>)
  (lambda (x)
    (call-with-port (open-output-string)
      (lambda (port)
        (write x port)
        (get-output-string port)))))

; (show (list 1 #false (list 3 4 (list 4))))
; (show #t)
; (show "asfd")

define-protocolの使い方

• メソッドは複数定義可能
• 型変数も複数取れる
• 戻り値多相は無い(モナドは作れない)
• 可変長引数は取れない
• メソッドのインスタンスごとにアリティを変えることは出来ない
• ディスパッチは線形時間(今後の最適化で典型ケースではO(1)になるはず)

equal?やwrite/displayをこれベースに置き換えたい。

考えられる応用:

• equal?
• write
• hash
• compare
• 算術演算子の特殊化