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