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)))

  (define-syntax define-overload
    (ir-macro-transformer
     (lambda (e i c)
       (define (impl def . body)
         (define name (car def))
         (define (get-param-names args)
           (let loop ((lst args) (ret '()))
             (if (null? lst)
                 (reverse ret)
                 (if (symbol? (car lst))
                     (loop (cdr lst) (cons (car lst) ret))
                     (loop (cdr lst) (cons (caar lst) ret))))))
         (define (get-preds args)
           (let loop ((lst args) (ret '()))
             (if (null? lst)
                 (reverse ret)
                 (if (list? (car lst))
                     (loop (cdr lst) (cons (reverse (car lst)) ret))
                     (loop (cdr lst) ret)))))
         (define param-names (get-param-names (cdr def)))
         (define preds (get-preds (cdr def)))
         (define old-func (gensym))
         `(begin
            (define ,old-func ,name)
            (define (,name ,@param-names)
              (if (and ,@preds)
                  ((lambda (,@param-names) ,@body) ,@param-names)
                  (,old-func ,@param-names)))))
       (define form (apply impl (cdr e)))
       ;; (display form) (newline)
       form))))