make `cases` work with positional args

9 years ago · a2fcd9acc2
parent 695b682773
commit a2fcd9acc2
1 changed files with 17 additions and 12 deletions
--- a/br/eopl.rkt
+++ b/br/eopl.rkt
@ -1,6 +1,6 @@
 #lang br
-(require rackunit (for-syntax br/datum sugar/debug))
+(require rackunit racket/struct (for-syntax br/datum sugar/debug))
-(provide define-datatype occurs-free?)
+(provide define-datatype cases occurs-free?)
 #;(begin
    (struct lc-exp () #:transparent)
@ -59,17 +59,22 @@
                         (occurs-free? search-var rator)
                         (occurs-free? search-var rand)))]))
-
+(define-syntax (cases stx)
-(define #'(cases-let <input-var> <subtype> (<field> ...) <body> ...)
+  (syntax-case stx (else)
-  (inject-syntax ([#'(<subtype-field> ...) (map-syntax (λ(field) (format-datum '~a-~a #'<subtype> field)) #'(<field> ...))])
+    [(_ <base-type> <input-var>
-                 #'(let ([<field> (<subtype-field> <input-var>)] ...)
+        [<subtype> (<positional-var> ...) <body> ...] ...
-                     <body> ...)))
+        [else <else-body> ...])
 (define #'(cases <base-type> <input-var> [<subtype> (<field> ...) <body> ...] ...)
     (inject-syntax ([#'(<subtype?> ...) (map-syntax (λ(s) (format-datum '~a? s)) #'(<subtype> ...))])
                    #'(cond
-                     [(<subtype?> <input-var>) (cases-let <input-var> <subtype> (<field> ...) <body> ...)] ...)))
+                        [(<subtype?> <input-var>) (match-let ([(list <positional-var> ...) (struct->list <input-var>)])
                                                    <body> ...)] ...
                                                                 [else <else-body> ...]))]
    [(_ <base-type> <input-var>
        <subtype-case> ...)
     #'(cases <base-type> <input-var>
         <subtype-case> ...
         [else (void)])]))
 (define (occurs-free? search-var exp)
  (cases lc-exp exp