ckscm-trait/trait.scm

(module trait (trait?
               define-trait
               define-trait-impl
               with-type
               with-type-of
               ;; functions below are supposed to be used only in
               ;; code generated by macros
               __create_trait
               __trait-get-func
               __trait-reg-func
               __trait-select-func
               __trait-select-func-of
               __trait-reg-func-to-cls)
  (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)
  
  (define func-to-class-table (make-hash-table))

  (define (__trait-reg-func-to-cls func cls)
    (hash-table-set! func-to-class-table func cls))

  (define (__trait-select-func pred func name)
    (define cls (hash-table-ref func-to-class-table func))
    (define func-list (hash-table-ref (trait-func-table cls)
                                      name))
    (define (find-in lst)
      (if (null? lst)
          '()
          (if (or (eq? pred (caar lst))
                  (null? (caar lst)))
              (cdar lst)
              (find-in (cdr lst)))))
    (find-in func-list))
  
  (define (__create_trait name func-names default-funcs)
    (let ((table (make-hash-table)))
      (define cls (make-trait name func-names table))
      (define (init-table func-names)
        (if (null? func-names)
            '()
            (let ()
              (hash-table-set! (trait-func-table cls)
                               (car func-names)
                               '())
              (init-table (cdr func-names)))))
      (init-table func-names)
      cls))

  (define (__trait-get-func cls func-sym obj)
    (define func-list (hash-table-ref (trait-func-table cls)
                                      func-sym))
    (define (find-in lst)
      (if (null? lst)
          '()
          (if (or (null? (caar lst))
                  ((caar lst) obj))
              (cdar lst)
              (find-in (cdr lst)))))
    (find-in func-list))

  (define (__trait-select-func-of obj func name)
    (define cls (hash-table-ref func-to-class-table func))
    (__trait-get-func cls name obj))
  
  (define (__trait-reg-func cls func-sym pred func)
    (define func-table (trait-func-table cls))
    (hash-table-set! func-table
                     func-sym
                     (cons (cons pred func)
                           (hash-table-ref func-table func-sym))))
  
  (define-macro (define-trait name . body)
    (let ()
      (define (func-def-tr entry)
        (define args (gensym))
        `(begin
           (define (,(car entry) . ,args)
             (apply (__trait-get-func ,name
                                      (quote ,(car entry))
                                      (car ,args))
                    ,args))
           (__trait-reg-func-to-cls ,(car entry) ,name)))
      (define (default-func-register-tr entry)
        `(__trait-reg-func ,name
                           (quote ,(car entry))
                           '()
                           ,(if (null? (cdr entry))
                                '(quote ())
                                (cadr entry))))
      (define (define-trait-tr name . body)
        `(begin
           (define ,name
             (__create_trait (quote ,name)
                             (quote ,(map car body))
                             (quote ,(map (lambda (x)
                                            (if (null? (cdr x))
                                                '()
                                                (cadr x)))
                                          body))))
           ,@(map func-def-tr body)
           ,@(map default-func-register-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 cls (car name))
        (define pred (cadr name))
        (define (reg-func-tr entry)
          `(__trait-reg-func ,cls
                             (quote ,(car entry))
                             ,pred
                             ,(cadr entry)))
        `(begin
           ,@(map reg-func-tr body)))
      (define form (apply define-trait-impl-tr (cons name body)))
      ;; (display form) (newline)
      form))

  (define-macro (with-type pred func)
    `(__trait-select-func ,pred ,func (quote ,func)))

  (define-macro (with-type-of obj func)
    `(__trait-select-func-of ,obj ,func (quote ,func))))