suzanne.soy/beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

make cases work with positional args

Browse Source
This commit is contained in:
Matthew Butterick 2016-03-17 10:48:53 -07:00
parent 695b682773
commit a2fcd9acc2
1 changed files with 17 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
br/eopl.rkt
View File

@ -1,6 +1,6 @@
#lang br
(require rackunit (for-syntax br/datum sugar/debug))
(provide define-datatype occurs-free?)
(require rackunit racket/struct (for-syntax br/datum sugar/debug))
(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)
(syntax-case stx (else)
[(_ <base-type> <input-var>
[<subtype> (<positional-var> ...) <body> ...] ...
[else <else-body> ...])
(inject-syntax ([#'(<subtype?> ...) (map-syntax (λ(s) (format-datum '~a? s)) #'(<subtype> ...))])
#'(cond
[(<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 #'(cases-let <input-var> <subtype> (<field> ...) <body> ...)
(inject-syntax ([#'(<subtype-field> ...) (map-syntax (λ(field) (format-datum '~a-~a #'<subtype> field)) #'(<field> ...))])
#'(let ([<field> (<subtype-field> <input-var>)] ...)
<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> ...)] ...)))
(define (occurs-free? search-var exp)
(cases lc-exp exp