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

fixup

Browse Source
This commit is contained in:
Matthew Butterick 2016-08-12 22:00:08 -04:00
parent 4c46f9849f
commit 4847adf7e9
3 changed files with 43 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
beautiful-racket-lib/br/define.rkt
View File

@ -1,8 +1,7 @@
#lang racket/base #lang racket/base
(require (require
racket/function racket/function
(for-syntax racket/list (for-syntax racket/base
racket/base
syntax/parse syntax/parse
br/syntax br/syntax
racket/syntax racket/syntax
@ -36,7 +35,7 @@
(for*/list ([pat-arg (in-list (syntax-flatten pats))] (for*/list ([pat-arg (in-list (syntax-flatten pats))]
[pat-datum (in-value (syntax->datum pat-arg))] [pat-datum (in-value (syntax->datum pat-arg))]
#:when (and (symbol? pat-datum) #: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 (string-prefix? (symbol->string pat-datum) pattern-arg-prefixer))
(not (upcased? (symbol->string pat-datum))))) (not (upcased? (symbol->string pat-datum)))))
pat-arg))) pat-arg)))

89
beautiful-racket-lib/br/experimental/eopl.rkt
View File

@ -2,41 +2,15 @@
(require racket/struct (for-syntax br/datum)) (require racket/struct (for-syntax br/datum))
(provide define-datatype cases occurs-free?) (provide define-datatype cases occurs-free?)
#;(begin (define-macro (define-datatype BASE-TYPE _base-type-predicate?
(struct lc-exp () #:transparent) (SUBTYPE [FIELD FIELD-PREDICATE?] ...) ...)
(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?] ...) ...)
#'(begin #'(begin
(struct _base-type () #:transparent #:mutable) (struct BASE-TYPE () #:transparent #:mutable)
(struct _subtype _base-type (_field ...) #:transparent #:mutable (struct SUBTYPE BASE-TYPE (FIELD ...) #:transparent #:mutable
#:guard (λ(_field ... name) #:guard (λ(FIELD ... name)
(unless (_field-predicate? _field) (unless (FIELD-PREDICATE? FIELD)
(error name (format "arg ~a is not ~a" _field '_field-predicate?))) ... (error name (format "arg ~a is not ~a" FIELD 'FIELD-PREDICATE?))) ...
(values _field ...))) ...)) (values FIELD ...))) ...))
(define-datatype lc-exp lc-exp? (define-datatype lc-exp lc-exp?
@ -45,36 +19,37 @@
(app-exp [rator lc-exp?] [rand lc-exp?])) (app-exp [rator lc-exp?] [rand lc-exp?]))
#;(define (occurs-free? search-var exp) #;(define-syntax (cases stx)
(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) (syntax-case stx (else)
[(_ _base-type _input-var [(_ _base-type INPUT-VAR
[_subtype (_positional-var ...) . _body] ... [SUBTYPE (POSITIONAL-VAR ...) . _body] ...
[else . _else-body]) [else . _else-body])
(inject-syntax ([#'(_subtype? ...) (suffix-id #'(_subtype ...) "?")]) (inject-syntax ([#'(_subtype? ...) (suffix-id #'(SUBTYPE ...) "?")])
#'(cond #'(cond
[(_subtype? _input-var) (match-let ([(list _positional-var ...) (struct->list _input-var)]) [(_subtype? INPUT-VAR) (match-let ([(list POSITIONAL-VAR ...) (struct->list INPUT-VAR)])
. _body)] ... . _body)] ...
[else . _else-body]))] [else . _else-body]))]
[(_ _base-type _input-var [(_ _base-type INPUT-VAR
_subtype-case ...) SUBTYPE-CASE ...)
#'(cases _base-type _input-var #'(cases _base-type INPUT-VAR
_subtype-case ... SUBTYPE-CASE ...
[else (void)])])) [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) (define (occurs-free? search-var exp)
(cases lc-exp exp (cases lc-exp exp

7
beautiful-racket-lib/br/syntax.rkt
View File

@ -139,9 +139,10 @@
(define (syntax-flatten stx) (define (syntax-flatten stx)
(flatten (flatten
(let loop ([stx stx]) (let loop ([stx stx])
(define maybe-list (syntax->list stx)) (define maybe-pair (let ([e-stx (syntax-e stx)])
(if maybe-list (and (pair? e-stx) (flatten e-stx))))
(map loop maybe-list) (if maybe-pair
(map loop maybe-pair)
stx)))) stx))))
(define-syntax-rule (begin-label LABEL . EXPRS) (define-syntax-rule (begin-label LABEL . EXPRS)