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