make trait impl lexically scoped

README.md

@@ -1,6 +1,8 @@
 # Trait
 
-A trait/typeclass system for Chicken Scheme.
+A trait/typeclass system for Chicken Scheme, inspired by [*Type Classes Without Types*](https://www.schemeworkshop.org/2005/01-garcia/01-garcia.pdf). But currently my implementation is in a very early stage, so it's much more simpler and inferior than the one described in the paper.
+
+I prefer the name *typeclass*, but there has been an egg named typeclass already. So I borrowed the word *trait* from Rust.
 
 ## Example
 
@@ -78,7 +80,7 @@ A trait/typeclass system for Chicken Scheme.
     
     (display ((with-type nullable? return) 42))
     (newline)
-    
+
     (define x (make-some 42))
-    (display ((with-type-of x return) 81))
-    (newline)
+    (let ((return (with-type-of x Monad return)))
+      (display (nullable-value (return 99))))

trait.egg

@@ -1,8 +1,8 @@
 ;; -*- scheme -*-
 ((author "Mistivia")
- (synopsis "A trait/typeclass system for Scheme")
- (license "bsd")
+ (synopsis "A trait/typeclass system")
+ (license "BSD")
  (category lang-ext)
  (dependencies srfi-69)
  ;; (test-dependencies test)
- (components (extension trait)))
+ (components (extension trait)))

trait.scm

@@ -1,16 +1,11 @@
 (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)
+               ;; functions below used only in macros
+               get-trait-func
+               create-trait)
+
   (import scheme
           (chicken base)
           (chicken syntax)
@@ -28,93 +23,43 @@
                  ,@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-record trait name func-names func-table pred parent)
   
-  (define (__create_trait name func-names default-funcs)
+  (define (create-trait name func-names funcs pred parent)
     (let ((table (make-hash-table)))
-      (define cls (make-trait name func-names table))
-      (define (init-table func-names)
+      (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)
-                               '())
-              (init-table (cdr func-names)))))
-      (init-table func-names)
+                               (car funcs))
+              (init-table (cdr func-names) (cdr funcs)))))
+      (init-table func-names funcs)
       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 ,(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))
-                             (quote ,(map (lambda (x)
-                                            (if (null? (cdr x))
-                                                '()
-                                                (cadr x)))
-                                          body))))
-           ,@(map func-def-tr body)
-           ,@(map default-func-register-tr body)))
+             (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))
@@ -122,21 +67,46 @@
   (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 (reg-func-tr entry)
-          `(__trait-reg-func ,cls
-                             (quote ,(car entry))
-                             ,pred
-                             ,(cadr entry)))
+        (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
-           ,@(map reg-func-tr body)))
+           (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-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))))
+  (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))))