Skip to content

Commit

Permalink
!114 equals, is-instance-of, case-class? for define-case-class in (li…
Browse files Browse the repository at this point in the history 
…ii base)
  • Loading branch information
@da-liii
da-liii committed Jan 12, 2025
1 parent 4e762f1 commit 1caa7ab
Show file tree
Hide file tree
Showing 7 changed files with 186 additions and 153 deletions.
54 changes: 20 additions & 34 deletions GoldfishLang.tmu
View file
Original file line number Diff line number Diff line change
Expand Up @@ -96,19 +96,11 @@

(export

\ \ option option? option=? none
\ \ option none

\ \ case-integer case-integer? case-integer=?
\ \ case-integer case-char case-string

\ \ case-char case-char? case-char=?

\ \ case-string case-string? case-string=?

\ \ case-list case-list? case-list=?

\ \ case-vector case-vector? case-vector=?

\ \ case-hash-table case-hash-table? case-hash-table=?
\ \ case-list case-vector case-hash-table

\ \ box

Expand All @@ -130,7 +122,7 @@

\;

;(check-set-mode! 'report-failed)
(check-set-mode! 'report-failed)

\;
</scm-chunk>
Expand Down Expand Up @@ -287,6 +279,8 @@

<\goldfish-chunk|tests/goldfish/liii/lang-test.scm|true|true>
(check-true ((option "str") :equals (option "str")))

\;
</goldfish-chunk>

<paragraph|option%defined?>
Expand Down Expand Up @@ -389,13 +383,9 @@

<subsection|谓词>

<\goldfish-chunk|goldfish/liii/lang.scm|true|true>
(define (%equals that)
<paragraph|case-integer%equals>

\ \ (equal? data (that 'data)))

\;
</goldfish-chunk>
该函数由define-case-class自动生成。

<\goldfish-chunk|tests/goldfish/liii/lang-test.scm|true|true>
(check-true ((box 42) :equals (box 42)))
Expand Down Expand Up @@ -491,13 +481,7 @@

<paragraph|case-char%equals>

<\goldfish-chunk|goldfish/liii/lang.scm|true|true>
(define (%equals that)

\ \ (equal? code-point (that 'code-point)))

\;
</goldfish-chunk>
该函数由<scm|define-case-class>自动生成。

<\goldfish-chunk|tests/goldfish/liii/lang-test.scm|true|true>
(check-true ((case-char #x30) :equals (case-char #x30)))
Expand Down Expand Up @@ -929,16 +913,10 @@

<paragraph|case-string%equals>

<\goldfish-chunk|goldfish/liii/lang.scm|true|true>
(define (%equals that)

\ \ (string=? data (that 'data)))

\;
</goldfish-chunk>
该函数由<scm|define-case-class>自动生成。

<\goldfish-chunk|tests/goldfish/liii/lang-test.scm|true|true>
(check-true ((box "42") :equals (box "42")))
(check (box "42") =\<gtr\> (box "42"))

(check-false ((box "41") :equals (box "42")))

Expand Down Expand Up @@ -1181,6 +1159,14 @@
\;
</goldfish-chunk>

<\goldfish-chunk|tests/goldfish/liii/lang-test.scm|true|true>
(check (box (list (box 1) (box 2) (box 3)))

\ \ =\<gtr\> (((box 1) :to 3) :map box))

\;
</goldfish-chunk>

<paragraph|case-list%forall>

<\goldfish-chunk|goldfish/liii/lang.scm|true|true>
Expand All @@ -1192,7 +1178,7 @@
</goldfish-chunk>

<\goldfish-chunk|tests/goldfish/liii/lang-test.scm|true|true>
(let1 lst (case-list '(1 2 3 4 5))
(let1 lst (box '(1 2 3 4 5))

\ \ (check (lst :forall (lambda (x) (\<gtr\> x 0))) =\<gtr\> #t)

Expand Down
186 changes: 113 additions & 73 deletions GoldfishScheme.tmu
View file
Original file line number Diff line number Diff line change
Expand Up @@ -408,7 +408,7 @@

\ \ ; Extra structure

\ \ let1 \ typed-lambda typed-define define-case-class
\ \ let1 \ typed-lambda typed-define define-case-class case-class?

)

Expand Down Expand Up @@ -3519,46 +3519,6 @@

<section|增补函数>

<paragraph|==><index|==><scm|(x y) =\<gtr\> bool>

<scm|equal?>的语法糖。

<\scm-chunk|goldfish/liii/base.scm|true|true>
(define == equal?)

\;
</scm-chunk>

\;

<\scm-chunk|tests/goldfish/liii/base-test.scm|true|true>
(check (== (list 1 2) (list 1 2)) =\<gtr\> #t)

(check (!= (list 1 2) (list 1 2)) =\<gtr\> #f)

\;
</scm-chunk>

<paragraph|!=><index|!=><scm|(x y) =\<gtr\> bool>

语法糖。

<\scm-chunk|goldfish/liii/base.scm|true|true>
(define (!= left right)

\ \ (not (equal? left right)))

\;
</scm-chunk>

<\scm-chunk|tests/goldfish/liii/base-test.scm|true|true>
(check (== (list 1 2) (list 1 2)) =\<gtr\> #t)

(check (!= (list 1 2) (list 1 2)) =\<gtr\> #f)

\;
</scm-chunk>

<paragraph|loose-car>

<\scm-chunk|goldfish/liii/base.scm|true|true>
Expand Down Expand Up @@ -3904,6 +3864,22 @@

\ \ \ \ \ \ \ (typed-define ,(cons class-name fields)

\ \ \ \ \ \ \ \ \ (define (%is-instance-of x)

\ \ \ \ \ \ \ \ \ \ \ (eq? x ',class-name))

\ \ \ \ \ \ \ \ \

\ \ \ \ \ \ \ \ \ (typed-define (%equals (that case-class?))

\ \ \ \ \ \ \ \ \ \ \ (and (that :is-instance-of ',class-name)

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ,@(map (lambda (field)

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ `(equal? ,(car field) (that ',(car field))))

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ fields)))

\;

\ \ \ \ \ \ \ \ \ ,@extra-operations
Expand All @@ -3914,17 +3890,21 @@

\ \ \ \ \ \ \ \ \ \ \ (cond

\ \ \ \ \ \ \ \ \ \ \ \ \ ((eq? msg 'type) ',class-name)
\ \ \ \ \ \ \ \ \ \ \ \ \ ((eq? msg :is-instance-of) (apply %is-instance-of args))

\ \ \ \ \ \ \ \ \ \ \ \ \ ((eq? msg :equals) (apply %equals args))

\ \ \ \ \ \ \ \ \ \ \ \ \

\ \ \ \ \ \ \ \ \ \ \ \ \ ,@(map (lambda (field)

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ‘((eq? msg ',(car field)) ,(car field)))
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ `((eq? msg ',(car field)) ,(car field)))

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ fields)

\ \ \ \ \ \ \ \ \ \ \ \ \ ,@(map (lambda (field key-field)

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ‘((eq? msg ,key-field)
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ `((eq? msg ,key-field)

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (,constructor ,@(map (lambda (f)

Expand All @@ -3942,33 +3922,15 @@

\ \ \ \ \ \ \ \ \ \ \ \ \ ,@(map (lambda (op)

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ‘((eq? msg ,(string-\<gtr\>symbol (string-append ":" (substring (symbol-\<gtr\>string (caadr op)) 1))))
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ `((eq? msg ,(string-\<gtr\>symbol (string-append ":" (substring (symbol-\<gtr\>string (caadr op)) 1))))

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (apply ,(caadr op) args)))

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ extra-operations)

\;

\ \ \ \ \ \ \ \ \ \ \ \ \ (else (value-error "No such field or operation " msg " in case class " ,class-name)))))

\;

\ \ \ \ \ \ \ (define (,type-pred obj)

\ \ \ \ \ \ \ \ \ (and (procedure? obj)

\ \ \ \ \ \ \ \ \ \ \ \ \ \ (eq? (obj 'type) ',class-name)))

\;

\ \ \ \ \ \ \ (typed-define (,equality-pred (p1 ,type-pred) (p2 ,type-pred))

\ \ \ \ \ \ \ \ \ (and ,@(map (lambda (field)

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ‘(equal? (p1 ',(car field)) (p2 ',(car field))))

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ fields))))))
\ \ \ \ \ \ \ \ \ \ \ \ \ (else (value-error "No such field or operation " msg " in case class " ,class-name))))))))

\;
</goldfish-chunk>
Expand All @@ -3994,13 +3956,7 @@

\ \ (check-catch 'value-error (bob 'sex))

\ \ (check-true (person? bob)))

\;

(check-true (person=? (person "Bob" 21) (person "Bob" 21)))

(check-false (person=? (person "Bob" 21) (person "Bob" 20)))
\ \ (check-true (bob :is-instance-of 'person)))

\;

Expand All @@ -4014,7 +3970,7 @@

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (case* x

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ((#\<less\>person?\<gtr\>) (x 'name))
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ((#\<less\>procedure?\<gtr\>) (x 'name))

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (else (???))))))

Expand Down Expand Up @@ -4057,6 +4013,90 @@
\;
</scm-chunk>

<paragraph|case-class?>

case class的前两个方法必须是<scm|:is-instance-of>和<scm|:equals>。

<\goldfish-chunk|goldfish/liii/base.scm|true|true>
(define (case-class? x)

\ \ (and-let* ((is-proc? (procedure? x))

\ \ \ \ \ \ \ \ \ \ \ \ \ (source (procedure-source x))

\ \ \ \ \ \ \ \ \ \ \ \ \ (body (source 2))

\ \ \ \ \ \ \ \ \ \ \ \ \ (is-cond? (eq? (car body) 'cond))

\ \ \ \ \ \ \ \ \ \ \ \ \ (at-least-2? (\<gtr\>= (length body) 3))

\ \ \ \ \ \ \ \ \ \ \ \ \ (pred1 ((body 1) 0))

\ \ \ \ \ \ \ \ \ \ \ \ \ (pred2 ((body 2) 0)))

\ \ \ \ (and (equal? pred1 '(eq? msg :is-instance-of))

\ \ \ \ \ \ \ \ \ (equal? pred2 '(eq? msg :equals)))))

\;
</goldfish-chunk>

<\scm-chunk|tests/goldfish/liii/base-test.scm|true|true>
(check-true (case-class? (person "Bob" 21)))

\;
</scm-chunk>

<paragraph|==><index|==><scm|(x y) =\<gtr\> bool>

<scm|equal?>的语法糖。

<\scm-chunk|goldfish/liii/base.scm|true|true>
(define (== left right)

\ \ (if (and (case-class? left) (case-class? right))

\ \ \ \ \ \ (left :equals right)

\ \ \ \ \ \ (equal? left right)))

\;
</scm-chunk>

\;

<\scm-chunk|tests/goldfish/liii/base-test.scm|true|true>
(check (== (list 1 2) (list 1 2)) =\<gtr\> #t)

(check (!= (list 1 2) (list 1 2)) =\<gtr\> #f)

(check-true (== (person "Bob" 21) (person "Bob" 21)))

\;
</scm-chunk>

<paragraph|!=><index|!=><scm|(x y) =\<gtr\> bool>

语法糖。

<\scm-chunk|goldfish/liii/base.scm|true|true>
(define (!= left right)

\ \ (not (== left right)))

\;
</scm-chunk>

<\scm-chunk|tests/goldfish/liii/base-test.scm|true|true>
(check (== (list 1 2) (list 1 2)) =\<gtr\> #t)

(check (!= (list 1 2) (list 1 2)) =\<gtr\> #f)

(check-true (!= (person "Bob" 20) (person "Bob" 21)))

\;
</scm-chunk>

\;

<section|结尾>
Expand Down Expand Up @@ -4968,7 +5008,7 @@
<\scm-chunk|goldfish/srfi/srfi-78.scm|true|true>
(define-macro (check expr =\<gtr\> expected)

\ \ `(check:proc ',expr (lambda () ,expr) equal? ,expected))
\ \ `(check:proc ',expr (lambda () ,expr) == ,expected))

\;
</scm-chunk>
Expand Down
Loading

0 comments on commit 1caa7ab

Please sign in to comment.