diff --git a/beautiful-racket-lib/br/eopl.rkt b/beautiful-racket-lib/br/eopl.rkt index 03bfc03..78648ea 100644 --- a/beautiful-racket-lib/br/eopl.rkt +++ b/beautiful-racket-lib/br/eopl.rkt @@ -61,18 +61,18 @@ (define-syntax (cases stx) (syntax-case stx (else) - [(_ - [ ( ...) ...] ... - [else ...]) - (inject-syntax ([#'( ...) (map-syntax (λ(s) (format-datum '~a? s)) #'( ...))]) + [(_ _base-type _input-var + [_subtype (_positional-var ...) . _body] ... + [else . _else-body]) + (inject-syntax ([#'(_subtype? ...) (suffix-ids #'(_subtype ...) "?")]) #'(cond - [( ) (match-let ([(list ...) (struct->list )]) - ...)] ... - [else ...]))] - [(_ - ...) - #'(cases - ... + [(_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)])])) diff --git a/beautiful-racket-lib/br/subscope.rkt b/beautiful-racket-lib/br/subscope.rkt index d3d9674..81ffb26 100644 --- a/beautiful-racket-lib/br/subscope.rkt +++ b/beautiful-racket-lib/br/subscope.rkt @@ -3,12 +3,12 @@ (define #'(introduce-scope _color . _parents) (with-syntax ([color #'_color] - [color-string (format "~a" (syntax->datum #'_color))] - [color:define (format-id #f "~a:define" #'_color)] - [color:id (format-id #f "~a:id" #'_color)] - [color-binding-id (format-id #f "~a-binding-id" #'_color)] - [color-binding-form (format-id #f "~a-binding-form" #'_color)] - [color-id (format-id #f "~a-id" #'_color)] + [color-string (format-string "~a" #'_color)] + [color:define (suffix-id #'_color ":define")] + [color:id (suffix-id #'_color ":id")] + [color-binding-id (suffix-id #'_color "-binding-id")] + [color-binding-form (suffix-id #'_color "-binding-form")] + [color-id (suffix-id #'_color "-id")] [module-name (generate-temporary)] [parents (if (pair? (syntax->list #'_parents)) (car (syntax->list #'_parents)) @@ -16,19 +16,19 @@ (replace-context #'_color #'(begin (module module-name br - (require (for-syntax br/datum br/syntax)) + (require (for-syntax br/datum br/scope)) (provide (for-syntax (all-defined-out)) (all-defined-out)) (begin-for-syntax (define-scope color parents)) (define #'(color:define _id-in _expr) - (with-syntax* ([color:id (shared-syntax (format-datum "~a:~a" color-string #'_id-in))] - [color-binding-id (color-binding-form #'_id-in)] - [color-id (color #'color-binding-id)]) - #'(begin - (define color-binding-id _expr) - (define-syntax color:id - (syntax-id-rules () - [_ color-id])))))) + (inject-syntax* ([#'color:id (shared-syntax (prefix-id color-string ":" #'_id-in))] + [#'color-binding-id (color-binding-form #'_id-in)] + [#'color-id (color #'color-binding-id)]) + #'(begin + (define color-binding-id _expr) + (define-syntax color:id + (syntax-id-rules () + [_ color-id])))))) (require 'module-name)))))