define-case-class with type and optional default value in (liii case)

GoldfishScheme.tmu

@@ -147,7 +147,7 @@
 
   <section|许可证>
 
-  <\scm-chunk|goldfish/scheme/base.scm|false|true>
+  <\goldfish-chunk|goldfish/scheme/base.scm|false|true>
     ;
 
     ; Copyright (C) 2024 The Goldfish Scheme Authors
@@ -179,9 +179,9 @@
     ;
 
     \;
-  </scm-chunk>
+  </goldfish-chunk>
 
-  <\scm-chunk|goldfish/liii/base.scm|false|true>
+  <\goldfish-chunk|goldfish/liii/base.scm|false|true>
     ;
 
     ; Copyright (C) 2024 The Goldfish Scheme Authors
@@ -213,7 +213,7 @@
     ;
 
     \;
-  </scm-chunk>
+  </goldfish-chunk>
 
   \;
 
@@ -319,7 +319,7 @@
     \;
   </scm-chunk>
 
-  <\scm-chunk|goldfish/liii/base.scm|true|true>
+  <\goldfish-chunk|goldfish/liii/base.scm|true|true>
     (define-library (liii base)
 
     (import (scheme base)
@@ -404,14 +404,14 @@
 
     \ \ ; Extra routines for (liii base)
 
-    \ \ == != display* in? let1 compose identity typed-lambda
+    \ \ == != display* in? let1 compose identity typed-lambda typed-define
 
     )
 
     (begin
 
     \;
-  </scm-chunk>
+  </goldfish-chunk>
 
   <section|测试>
 
@@ -3671,6 +3671,68 @@
     \;
   </scm-chunk>
 
+  <paragraph|typed-define>
+
+  <\goldfish-chunk|goldfish/liii/base.scm|true|true>
+    (define-macro (typed-define name-and-params body)
+
+    \ \ (let* ((name (car name-and-params))
+
+    \ \ \ \ \ \ \ \ \ (params (cdr name-and-params)))
+
+    \ \ \ \ `(define* (,name ,@(map (lambda (param)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (let ((param-name (car param))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (type-pred (cadr param))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (default-value (cddr param)))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (if (null? default-value)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ param-name ; 无默认值时直接使用参数名
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ `(,param-name ,(car default-value))))) ; 有默认值时使用默认值
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ params))
+
+    \;
+
+    \ \ \ \ \ \ \ ,@(map (lambda (param)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (let ((param-name (car param))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (type-pred (cadr param)))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ `(unless (,type-pred ,param-name)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (error 'type-error (string-append "Invalid type for " (symbol-\<gtr\>string ',param-name))))))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ params)
+
+    \;
+
+    \ \ \ \ \ \ \ ,body)))
+
+    \;
+  </goldfish-chunk>
+
+  <\goldfish-chunk|tests/goldfish/liii/base-test.scm|true|true>
+    (typed-define (person (name string? "Bob") (age integer?))
+
+    \ \ (string-append name " is " (number-\<gtr\>string age) " years old"))
+
+    \;
+
+    (check (person :age 21) =\<gtr\> "Bob is 21 years old")
+
+    (check (person :name "Alice" :age 25) =\<gtr\> "Alice is 25 years old")
+
+    (check-catch 'type-error (person :name 123 :age 25))
+
+    \;
+  </goldfish-chunk>
+
   \;
 
   <section|结尾>
@@ -5196,7 +5258,7 @@
   <paragraph|define-case-class>
 
   <\scm-chunk|tests/goldfish/liii/case-test.scm|true|true>
-    (define-case-class person ((name "Bob") (age 21)))
+    (define-case-class person ((name string? "Bob") (age integer?)))
 
     \;
 
@@ -5209,6 +5271,10 @@
     \ \ (check ((bob :name "hello") 'name) =\<gtr\> "hello"))
 
     \;
+
+    (check-catch 'type-error (person 1 21))
+
+    \;
   </scm-chunk>
 
   <paragraph|case*><index|case*>

goldfish/liii/base.scm

@@ -56,7 +56,7 @@
   ; SRFI-8
   receive
   ; Extra routines for (liii base)
-  == != display* in? let1 compose identity typed-lambda
+  == != display* in? let1 compose identity typed-lambda typed-define
 )
 (begin
 
@@ -116,6 +116,27 @@
                   args)
            ,@body))))
 
+(define-macro (typed-define name-and-params body)
+  (let* ((name (car name-and-params))
+         (params (cdr name-and-params)))
+    `(define* (,name ,@(map (lambda (param)
+                              (let ((param-name (car param))
+                                    (type-pred (cadr param))
+                                    (default-value (cddr param)))
+                                (if (null? default-value)
+                                    param-name ; 无默认值时直接使用参数名
+                                    `(,param-name ,(car default-value))))) ; 有默认值时使用默认值
+                            params))
+
+       ,@(map (lambda (param)
+                (let ((param-name (car param))
+                      (type-pred (cadr param)))
+                  `(unless (,type-pred ,param-name)
+                     (error 'type-error (string-append "Invalid type for " (symbol->string ',param-name))))))
+              params)
+
+       ,body)))
+
 ) ; end of begin
 ) ; end of define-library
 

goldfish/liii/case.scm

@@ -15,6 +15,7 @@
 ;
 
 (define-library (liii case)
+(import (liii base))
 (export case* define-case-class)
 (begin
 
@@ -24,17 +25,12 @@
                            (string->symbol (string-append ":" (symbol->string (car field)))))
                          fields)))
     `(begin
-       ;; 定义构造函数
-       (define* (,constructor ,@(map (lambda (field)
-                                       `(,(car field) ,(cadr field)))
-                                     fields))
+       (typed-define ,(cons class-name fields)
          (lambda (msg . args)
            (cond
-             ;; 字段访问
              ,@(map (lambda (field)
                       `((eq? msg ',(car field)) ,(car field)))
                     fields)
-             ;; 字段更新
              ,@(map (lambda (field key-field)
                       `((eq? msg ,key-field)
                         (,constructor ,@(map (lambda (f)
@@ -43,8 +39,7 @@
                                                    (car f)))
                                              fields))))
                     fields key-fields)
-             ;; 未知消息
-             (else (error "Unknown message"))))))))
+             (else (value-error "Unknown message" msg))))))))
 
 ; 0 clause BSD, from S7 repo case.scm
 (define case* 

tests/goldfish/liii/base-test.scm

@@ -677,6 +677,13 @@
 (check (add3 1 2 3) => 6)
 (check-catch 'type-error (add3 1.2 2 3))
 
+(typed-define (person (name string? "Bob") (age integer?))
+  (string-append name " is " (number->string age) " years old"))
+
+(check (person :age 21) => "Bob is 21 years old")
+(check (person :name "Alice" :age 25) => "Alice is 25 years old")
+(check-catch 'type-error (person :name 123 :age 25))
+
 (check-report)
 
 (check (make-list 3 #\a) => (list #\a #\a #\a))

tests/goldfish/liii/case-test.scm

@@ -3,13 +3,15 @@
 
 (check-set-mode! 'report-failed)
 
-(define-case-class person ((name "Bob") (age 21)))
+(define-case-class person ((name string? "Bob") (age integer?)))
 
 (let1 bob (person :name "Bob" :age 21)
   (check (bob 'name) => "Bob")
   (check (bob 'age) => 21)
   (check ((bob :name "hello") 'name) => "hello"))
 
+(check-catch 'type-error (person 1 21))
+
 ; 0 clause BSD, from S7 repo s7test.scm
 (define (scase x)
   (case* x