!115 apply for define-case-class, case-list, case-vector

GoldfishLang.tmu

@@ -1087,6 +1087,24 @@
     \;
   </goldfish-chunk>
 
+  <paragraph|case-list%apply>
+
+  <\goldfish-chunk|goldfish/liii/lang.scm|true|true>
+    (define (%apply n)
+
+    \ \ (list-ref data n))
+
+    \;
+  </goldfish-chunk>
+
+  <\goldfish-chunk|tests/goldfish/liii/lang-test.scm|true|true>
+    (check ((box '(1 2 3)) :apply 0) =\<gtr\> 1)
+
+    (check ((box '(1 2 3)) 0) =\<gtr\> 1)
+
+    \;
+  </goldfish-chunk>
+
   <paragraph|case-list%find><typehint|((pred procedure?)) =\<gtr\> option?>
 
   <\scm-chunk|goldfish/liii/lang.scm|true|true>
@@ -1507,6 +1525,24 @@
     \;
   </goldfish-chunk>
 
+  <paragraph|case-vector%apply>
+
+  <\goldfish-chunk|goldfish/liii/lang.scm|true|true>
+    (define (%apply n)
+
+    \ \ (vector-ref data n))
+
+    \;
+  </goldfish-chunk>
+
+  <\goldfish-chunk|tests/goldfish/liii/lang-test.scm|true|true>
+    (check ((box #(1 2 3)) :apply 1) =\<gtr\> 2)
+
+    (check ((box #(1 2 3)) 1) =\<gtr\> 2)
+
+    \;
+  </goldfish-chunk>
+
   <paragraph|case-vector%find>
 
   <\scm-chunk|goldfish/liii/lang.scm|true|true>

GoldfishScheme.tmu

@@ -3845,15 +3845,29 @@
 
   <paragraph|define-case-class><index|define-case-class>
 
+  <scm|define-case-class>用于在Goldfish Scheme定义类似Scala的样本类。
+
+  样本类对象实际上是函数，该函数的第一个参数可以是字段或者是方法，字段统一使用<scm|'field>表示，方法统一使用<scm|:method>表示，方法的实现统一采用<scm|%>作为前缀。比如<scm|(person :to-string)>实际上调用的是person对象的内部方法<scm|%to-string>。
+
+  内部方法将第一个参数之外剩下的参数作为参数传入，我们通过只处理部分参数，递归处理未处理参数的方式，可以实现方法调用链。比如
+
+  <\goldfish-code>
+    (l :filter positive? :filter zero?)
+
+    =\<gtr\> ((l :filter positve?) :filter zero?)
+  </goldfish-code>
+
+  在这个filter方法的实现中，<scm|%filter>这个内部方法只处理第一个参数，得到的结果仍旧是一个样本类对象，再使用得到的样本类对象处理剩余的参数。
+
+  define-case-class会自动生成这些内部方法：<scm|%equals>、<scm|%is-instance-of>和<scm|%apply>。其中<scm|%apply>是一个特殊方法，如果第一个参数没有命中字段或者方法，那么<scm|(person 1 2 3)>实际等价于<scm|(person :apply 1 2 3)>。
+
+  样本类的默认构造函数有类型校验，不做任何值校验的。如果需要做值校验，那么需要使用同名的函数覆盖define-case-class生成的默认实现。改同名函数我们成为该样本类的伴生函数。
+
   <\goldfish-chunk|goldfish/liii/base.scm|true|true>
     (define-macro (define-case-class class-name fields . extra-operations)
 
     \ \ (let ((constructor (string-\<gtr\>symbol (string-append (symbol-\<gtr\>string class-name))))
 
-    \ \ \ \ \ \ \ \ (type-pred (string-\<gtr\>symbol (string-append (symbol-\<gtr\>string class-name) "?")))
-
-    \ \ \ \ \ \ \ \ (equality-pred (string-\<gtr\>symbol (string-append (symbol-\<gtr\>string class-name) "=?")))
-
     \ \ \ \ \ \ \ \ (key-fields (map (lambda (field)
 
     \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (string-\<gtr\>symbol (string-append ":" (symbol-\<gtr\>string (car field)))))
@@ -3880,6 +3894,30 @@
 
     \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ fields)))
 
+    \ \ \ \ \ \ \ \ \ 
+
+    \ \ \ \ \ \ \ \ \ (define (%apply . args)
+
+    \ \ \ \ \ \ \ \ \ \ \ (when (null? args)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ (??? ,class-name "apply on zero args is not implemented"))
+
+    \ \ \ \ \ \ \ \ \ \ \ (cond ((equal? ((symbol-\<gtr\>string (car args)) 0) #\\:)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (??? ,class-name
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ "No such method: " (car args)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ "Please implement the method"))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (else
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (??? ,class-name "No such field: " (car args)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ "Please use the correct field name"
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ "Or you may implement %apply to process " args))))
+
     \;
 
     \ \ \ \ \ \ \ \ \ ,@extra-operations
@@ -3930,12 +3968,12 @@
 
     \;
 
-    \ \ \ \ \ \ \ \ \ \ \ \ \ (else (value-error "No such field or operation " msg " in case class " ,class-name))))))))
+    \ \ \ \ \ \ \ \ \ \ \ \ \ (else (apply %apply (cons msg args)))))))))
 
     \;
   </goldfish-chunk>
 
-  测试：不带伴生函数的样本类person
+  测试：不带用户自定义方法的样本类person
 
   <\goldfish-chunk|tests/goldfish/liii/base-test.scm|true|true>
     (define-case-class person
@@ -3954,7 +3992,9 @@
 
     \ \ (check ((bob :name "hello") 'name) =\<gtr\> "hello")
 
-    \ \ (check-catch 'value-error (bob 'sex))
+    \ \ (check-catch '??? (bob 'sex))
+
+    \ \ (check-catch '??? (bob :sex))
 
     \ \ (check-true (bob :is-instance-of 'person)))
 
@@ -3976,12 +4016,12 @@
 
     \ \ (check (get-name bob) =\<gtr\> "Bob")
 
-    \ \ (check-catch 'not-implemented-error (get-name 1)))
+    \ \ (check-catch '??? (get-name 1)))
 
     \;
   </goldfish-chunk>
 
-  测试：带伴生函数的样本类jerson
+  测试：带用户自定义方法的样本类jerson
 
   <\scm-chunk|tests/goldfish/liii/base-test.scm|true|true>
     (define-case-class jerson
@@ -4049,7 +4089,7 @@
 
   <paragraph|==><index|==><scm|(x y) =\<gtr\> bool>
 
-  <scm|equal?>的语法糖。
+  如果两个参数都是样本类，那么使用样本类的相等性判断；否则使用<scm|equal?>判断。
 
   <\scm-chunk|goldfish/liii/base.scm|true|true>
     (define (== left right)
@@ -4077,7 +4117,7 @@
 
   <paragraph|!=><index|!=><scm|(x y) =\<gtr\> bool>
 
-  语法糖。
+  ==的布尔逻辑取反。
 
   <\scm-chunk|goldfish/liii/base.scm|true|true>
     (define (!= left right)
@@ -4396,15 +4436,15 @@
   Scala风格未实现错误，一般用于标记为实现的接口。
 
   <\scm-chunk|goldfish/liii/error.scm|true|true>
-    (define (???)
+    (define (??? . args)
 
-    \ \ (error 'not-implemented-error "???"))
+    \ \ (apply error (cons '??? args)))
 
     \;
   </scm-chunk>
 
   <\goldfish-chunk|tests/goldfish/liii/error-test.scm|true|true>
-    (check-catch 'not-implemented-error (???))
+    (check-catch '??? (???))
 
     \;
   </goldfish-chunk>

goldfish/liii/base.scm

@@ -148,8 +148,6 @@
 
 (define-macro (define-case-class class-name fields . extra-operations)
   (let ((constructor (string->symbol (string-append (symbol->string class-name))))
-        (type-pred (string->symbol (string-append (symbol->string class-name) "?")))
-        (equality-pred (string->symbol (string-append (symbol->string class-name) "=?")))
         (key-fields (map (lambda (field)
                            (string->symbol (string-append ":" (symbol->string (car field)))))
                          fields)))
@@ -163,6 +161,18 @@
                 ,@(map (lambda (field)
                          `(equal? ,(car field) (that ',(car field))))
                        fields)))
+
+         (define (%apply . args)
+           (when (null? args)
+             (??? ,class-name "apply on zero args is not implemented"))
+           (cond ((equal? ((symbol->string (car args)) 0) #\:)
+                  (??? ,class-name
+                    "No such method: " (car args)
+                    "Please implement the method"))
+                 (else
+                  (??? ,class-name "No such field: " (car args)
+                       "Please use the correct field name"
+                       "Or you may implement %apply to process " args))))
 
          ,@extra-operations
 
@@ -188,7 +198,7 @@
                         (apply ,(caadr op) args)))
                     extra-operations)
 
-             (else (value-error "No such field or operation " msg " in case class " ,class-name))))))))
+             (else (apply %apply (cons msg args)))))))))
 
 (define (case-class? x)
   (and-let* ((is-proc? (procedure? x))

goldfish/liii/error.scm

@@ -48,8 +48,8 @@
 (define (value-error . args)
   (apply error (cons 'value-error args)))
 
-(define (???)
-  (error 'not-implemented-error "???"))
+(define (??? . args)
+  (apply error (cons '??? args)))
 
 ) ; begin
 ) ; define-library

goldfish/liii/lang.scm

@@ -193,6 +193,9 @@
 
 (define (%collect) data)
 
+(define (%apply n)
+  (list-ref data n))
+
 (define (%find pred)
   (let loop ((lst data))
     (cond
@@ -294,6 +297,9 @@
 
 (define (%collect) data)
 
+(define (%apply n)
+  (vector-ref data n))
+
   (define (%find p)
     (let loop ((i 0))
       (cond

tests/goldfish/liii/base-test.scm

@@ -704,7 +704,8 @@
   (check (bob 'name) => "Bob")
   (check (bob 'age) => 21)
   (check ((bob :name "hello") 'name) => "hello")
-  (check-catch 'value-error (bob 'sex))
+  (check-catch '??? (bob 'sex))
+  (check-catch '??? (bob :sex))
   (check-true (bob :is-instance-of 'person)))
 
 (check-catch 'type-error (person 1 21))
@@ -715,7 +716,7 @@
                    ((#<procedure?>) (x 'name))
                    (else (???))))))
   (check (get-name bob) => "Bob")
-  (check-catch 'not-implemented-error (get-name 1)))
+  (check-catch '??? (get-name 1)))
 
 (define-case-class jerson
   ((name string?)

tests/goldfish/liii/error-test.scm

@@ -41,7 +41,7 @@
 
 (check-catch 'value-error (value-error))
 
-(check-catch 'not-implemented-error (???))
+(check-catch '??? (???))
 
 (check-report)
 

tests/goldfish/liii/lang-test.scm

@@ -155,6 +155,9 @@
   (check (str :count char-alphabetic?) => 10)
 )
 
+(check ((box '(1 2 3)) :apply 0) => 1)
+(check ((box '(1 2 3)) 0) => 1)
+
 (let1 lst (case-list '(1 2 3 4 5))
   (check ((lst :find (lambda (x) (= x 3))) :get) => 3)
   (check ((lst :find (lambda (x) (> x 2))) :get) => 3)
@@ -222,6 +225,9 @@
   (check-catch 'type-error (l :make-string "[" "," 123))
 )
 
+(check ((box #(1 2 3)) :apply 1) => 2)
+(check ((box #(1 2 3)) 1) => 2)
+
 (let ((vec (case-vector #(1 2 3 4 5))))
   (check ((vec :find (lambda (x) (= x 3))) :get) => 3)
   (check ((vec :find (lambda (x) (> x 2))) :get) => 3)