init

LICENSE

@@ -0,0 +1,23 @@
+Copyright (c) 2024 Mistivia.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+   list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+   this list of conditions and the following disclaimer in the documentation
+   and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIEDi
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

release-info

@@ -0,0 +1,3 @@
+(repo git "https://git.sr.ht/~mistivia/{egg-name}")
+(uri targz "https://git.sr.ht/~mistivia/{egg-name}/archive/{egg-release}.tar.gz")
+(release "0.1")

trait.egg

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

trait.scm

@@ -0,0 +1,142 @@
+(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))))