ckscm-trait/trait.scm

(module trait (trait?
               define-trait
               define-trait-impl
               with-type-of
               ;; functions below used only in macros
               get-trait-func
               create-trait)

  (import scheme
          (chicken base)
          (chicken syntax)
          srfi-69)

  (define-syntax define-macro
    (er-macro-transformer
     (lambda (exp r c)
       (let ((def (cadr exp))
             (body (cddr exp)))
         `(define-syntax ,(car def)
            (er-macro-transformer
             (lambda (e2 r2 c2)
               (define (transform-func ,@(cdr def))
                 ,@body)
               (apply transform-func (cdr e2)))))))))
  ;; body
  (define-record trait name func-names func-table pred parent)
  
  (define (create-trait name func-names funcs pred parent)
    (let ((table (make-hash-table)))
      (define cls (make-trait name func-names table pred parent))
      (define (init-table func-names funcs)
        (if (null? func-names)
            '()
            (let ()
              (hash-table-set! (trait-func-table cls)
                               (car func-names)
                               (car funcs))
              (init-table (cdr func-names) (cdr funcs)))))
      (init-table func-names funcs)
      cls))

  (define-macro (define-trait name . body)
    (let ()
      (define (func-def-tr entry)
        (define args (gensym))
        `(define ,(car entry)
             ,(if (null? (cdr entry))
                  ''()
                  (cadr entry))))
      (define (define-trait-tr name . body)
        `(begin
           (define ,name
             (create-trait (quote ,name)
                           (quote ,(map car body))
                           (list ,@(map (lambda (x)
                                          (if (null? (cdr x))
                                              ''()
                                              (cadr x)))
                                        body))
                           '()
                           '()))
           ,@(map func-def-tr body)))
      (define form (apply define-trait-tr (cons name body)))
      ;; (display form) (newline)
      form))

  (define-macro (define-trait-impl name . body)
    (let ()
      (define (define-trait-impl-tr name . body)
        (define old-cls (gensym))
        (define cls (car name))
        (define pred (cadr name))
        (define (func-def-tr entry)
          (define old-func (gensym))
          (define args (gensym))
          `(begin
             (define ,old-func ,(car entry))
             (define (,(car entry) . ,args)
               (if (,pred (car ,args))
                   (apply ,(if (null? (cdr entry))
                               '()
                               (cadr entry))
                          ,args)
                   (apply ,old-func ,args)))))
        `(begin
           (define ,old-cls ,cls)
           (define ,cls
             (create-trait (quote ,cls)
                           (quote ,(map car body))
                           (list ,@(map (lambda (x)
                                   (if (null? (cdr x))
                                       ''()
                                       (cadr x)))
                                 body))
                           ,pred
                           ,old-cls))
           ,@(map func-def-tr body)))
      (define form (apply define-trait-impl-tr (cons name body)))
      ;; (display form) (newline)
      form))

  (define (get-trait-func trait obj func-name)
    (let loop ((cur trait))
      (cond ((null? (trait-parent cur))
             (hash-table-ref (trait-func-table cur) func-name))
            (((trait-pred cur) obj)
             (let ((func (hash-table-ref/default (trait-func-table cur) func-name #f)))
               (or func (loop (trait-parent cur)))))
            (else (loop (trait-parent cur))))))
  
  (define-macro (with-type-of obj trait func)
    `(get-trait-func ,trait ,obj (quote ,func))))