diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index 1136cdd..a83f208 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/beautiful-racket-lib/br/define.rkt @@ -1,8 +1,7 @@ #lang racket/base (require racket/function - (for-syntax racket/list - racket/base + (for-syntax racket/base syntax/parse br/syntax racket/syntax @@ -36,7 +35,7 @@ (for*/list ([pat-arg (in-list (syntax-flatten pats))] [pat-datum (in-value (syntax->datum pat-arg))] #:when (and (symbol? pat-datum) - (not (member pat-datum '(... _ else))) ; exempted from literality + (not (member pat-datum '(... _))) ; exempted from literality (not (string-prefix? (symbol->string pat-datum) pattern-arg-prefixer)) (not (upcased? (symbol->string pat-datum))))) pat-arg))) diff --git a/beautiful-racket-lib/br/experimental/eopl.rkt b/beautiful-racket-lib/br/experimental/eopl.rkt index c5353b7..90a167b 100644 --- a/beautiful-racket-lib/br/experimental/eopl.rkt +++ b/beautiful-racket-lib/br/experimental/eopl.rkt @@ -2,41 +2,15 @@ (require racket/struct (for-syntax br/datum)) (provide define-datatype cases occurs-free?) -#;(begin - (struct lc-exp () #:transparent) - - (struct var-exp lc-exp (var) #:transparent - #:guard (λ(var name) - (unless (symbol? var) - (error name (format "arg ~a not ~a" var 'symbol?))) - (values var))) - - (struct lambda-exp lc-exp (bound-var body) #:transparent - #:guard (λ(bound-var body name) - (unless (symbol? bound-var) - (error name (format "arg ~a not ~a" bound-var 'symbol?))) - (unless (lc-exp? body) - (error name (format "arg ~a not ~a" body 'lc-exp?))) - (values bound-var body))) - - (struct app-exp lc-exp (rator rand) #:transparent - #:guard (λ(rator rand name) - (unless (lc-exp? rator) - (error name (format "arg ~a not ~a" rator 'lc-exp?))) - (unless (lc-exp? rand) - (error name (format "arg ~a not ~a" rand 'lc-exp?))) - (values rator rand)))) - - -(define #'(define-datatype _base-type _base-type-predicate? - (_subtype [_field _field-predicate?] ...) ...) +(define-macro (define-datatype BASE-TYPE _base-type-predicate? + (SUBTYPE [FIELD FIELD-PREDICATE?] ...) ...) #'(begin - (struct _base-type () #:transparent #:mutable) - (struct _subtype _base-type (_field ...) #:transparent #:mutable - #:guard (λ(_field ... name) - (unless (_field-predicate? _field) - (error name (format "arg ~a is not ~a" _field '_field-predicate?))) ... - (values _field ...))) ...)) + (struct BASE-TYPE () #:transparent #:mutable) + (struct SUBTYPE BASE-TYPE (FIELD ...) #:transparent #:mutable + #:guard (λ(FIELD ... name) + (unless (FIELD-PREDICATE? FIELD) + (error name (format "arg ~a is not ~a" FIELD 'FIELD-PREDICATE?))) ... + (values FIELD ...))) ...)) (define-datatype lc-exp lc-exp? @@ -45,35 +19,36 @@ (app-exp [rator lc-exp?] [rand lc-exp?])) -#;(define (occurs-free? search-var exp) - (cond - [(var-exp? exp) (let ([var (var-exp-var exp)]) - (eqv? var search-var))] - [(lambda-exp? exp) (let ([bound-var (lambda-exp-bound-var exp)] - [body (lambda-exp-body exp)]) - (and (not (eqv? search-var bound-var)) - (occurs-free? search-var body)))] - [(app-exp? exp) (let ([rator (app-exp-rator exp)] - [rand (app-exp-rand exp)]) - (or - (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? ...) (suffix-id #'(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-syntax (cases stx) - (syntax-case stx (else) - [(_ _base-type _input-var - [_subtype (_positional-var ...) . _body] ... - [else . _else-body]) - (inject-syntax ([#'(_subtype? ...) (suffix-id #'(_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-macro-cases cases + [(_ BASE-TYPE INPUT-VAR + [SUBTYPE (POSITIONAL-VAR ...) . BODY] ... + [else . ELSE-BODY]) + (with-syntax ([(SUBTYPE? ...) (suffix-id #'(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 (occurs-free? search-var exp) diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index b493e7f..1e947bc 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/beautiful-racket-lib/br/syntax.rkt @@ -139,9 +139,10 @@ (define (syntax-flatten stx) (flatten (let loop ([stx stx]) - (define maybe-list (syntax->list stx)) - (if maybe-list - (map loop maybe-list) + (define maybe-pair (let ([e-stx (syntax-e stx)]) + (and (pair? e-stx) (flatten e-stx)))) + (if maybe-pair + (map loop maybe-pair) stx)))) (define-syntax-rule (begin-label LABEL . EXPRS)