mbutterick
/
beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

more cleanup

Browse Source
pull/2/head
Matthew Butterick 8 years ago
parent 066ea559cf
commit 460efbf3dc
1 changed files with 109 additions and 96 deletions
Show Stats Download Patch File Download Diff File

205
beautiful-racket-lib/br/define.rkt
Unescape Escape View File

@ -6,6 +6,7 @@
br/syntax br/syntax
racket/syntax racket/syntax
syntax/datum syntax/datum
syntax/define
racket/string)) racket/string))
(provide (all-defined-out) (provide (all-defined-out)
(for-syntax with-shared-id with-calling-site-id)) (for-syntax with-shared-id with-calling-site-id))
@ -13,21 +14,34 @@
(module+ test (module+ test
(require rackunit)) (require rackunit))
(define-for-syntax (upcased? str) (equal? (string-upcase str) str))
(define-for-syntax (generate-literals pats) (define-syntax (define+provide stx)
;; generate literals for any symbols that are not ... or _ or _underscore-prefixed (with-syntax ([(id lambda-exp)
(define pattern-arg-prefixer "_") (let-values ([(id-stx body-exp-stx)
(for/list ([pat-arg (in-list (syntax-flatten pats))] (normalize-definition stx (datum->syntax stx 'λ) #t #t)])
#:when (let ([pat-datum (syntax->datum pat-arg)]) (list id-stx body-exp-stx))])
(and (symbol? pat-datum) #'(begin
(not (member pat-datum '(... _ else))) ; exempted from literality (provide id)
(not (string-prefix? (symbol->string pat-datum) pattern-arg-prefixer)) (define id lambda-exp))))
(not (upcased? (symbol->string pat-datum))))))
pat-arg))
;; expose the caller context within br:define macros with syntax parameter
(begin-for-syntax (begin-for-syntax
(define (upcased? str)
(equal? (string-upcase str) str))
(define (generate-literals pats)
;; generate literals for any symbols that are not ... or _ or _underscore-prefixed
(define pattern-arg-prefixer "_")
(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 (string-prefix? (symbol->string pat-datum) pattern-arg-prefixer))
(not (upcased? (symbol->string pat-datum)))))
pat-arg)))
(begin-for-syntax
;; expose the caller context within br:define macros with syntax parameter
(require (for-syntax racket/base) racket/stxparam) (require (for-syntax racket/base) racket/stxparam)
(provide caller-stx shared-syntax) (provide caller-stx shared-syntax)
(define-syntax-parameter caller-stx (λ(stx) (error 'caller-stx-not-parameterized))) (define-syntax-parameter caller-stx (λ(stx) (error 'caller-stx-not-parameterized)))
@ -35,31 +49,19 @@
(define-syntax (define-cases stx) (define-syntax (define-cases stx)
(define-syntax-class syntaxed-id
#:literals (syntax)
#:description "id in syntaxed form"
(pattern (syntax name:id)))
(define-syntax-class syntaxed-thing
#:literals (syntax)
#:description "some datum in syntaxed form"
(pattern (syntax thing:expr)))
(syntax-parse stx (syntax-parse stx
#:literals (syntax) #:literals (syntax)
[(_ id:id)
;; defective for function (raise-syntax-error 'define-cases "no cases given" (syntax->datum #'id))]
[(_ top-id) [(_ id:id [(_ . pat-args:expr) . body:expr] ...)
(raise-syntax-error 'define-cases "no cases given" (syntax->datum #'top-id))] #'(define id
;; function matcher
[(_ top-id:id [(_ . pat-args) . body] ...)
#'(define top-id
(case-lambda (case-lambda
[pat-args . body] ... [pat-args . body] ...
[else (raise-syntax-error 'define-cases "no matching case for argument pattern" (object-name top-id))]))])) [else (raise-syntax-error 'id "no matching case for argument pattern")]))]
[else (raise-syntax-error
'define-cases
"no matching case for calling pattern"
(syntax->datum stx))]))
(module+ test (module+ test
@ -70,17 +72,17 @@
(check-equal? (f 42 5) 47)) (check-equal? (f 42 5) 47))
(define-syntax-rule (debug-define-macro (id . pat-args) body-exp) (define-syntax-rule (debug-define-macro (ID . PAT-ARGS) BODY)
(define-macro (id . pat-args) (define-macro (ID . PAT-ARGS)
#`(begin #`(begin
(for-each displayln (for-each displayln
(list (list
(format "input pattern = #'~a" '#,'(id . pat-args)) (format "input pattern = #'~a" '#,'(ID . PAT-ARGS))
(format "output pattern = #'~a" (cadr '#,'body-exp)) (format "output pattern = #'~a" (cadr '#,'BODY))
(format "invoked as = ~a" (syntax->datum #'(id . pat-args))) (format "invoked as = ~a" (syntax->datum #'(ID . PAT-ARGS)))
(format "expanded as = ~a" '#,(syntax->datum body-exp)) (format "expanded as = ~a" '#,(syntax->datum BODY))
(format "evaluated as = ~a" #,body-exp))) (format "evaluated as = ~a" #,BODY)))
#,body-exp))) #,BODY)))
(module+ test (module+ test
@ -95,7 +97,6 @@
(foo 10 11 12)) 1320))) (foo 10 11 12)) 1320)))
(begin-for-syntax (begin-for-syntax
(begin-for-syntax (begin-for-syntax
(require (for-syntax racket/base)) (require (for-syntax racket/base))
@ -106,81 +107,89 @@
(syntax-e form) (syntax-e form)
form))])))) form))]))))
(module+ test
(define-macro (dirty-maker ARG)
(with-syntax ([dirty-bar (datum->syntax caller-stx 'dirty-bar)])
#'(define dirty-bar (* ARG 2))))
(dirty-maker 42)
(check-equal? dirty-bar 84))
(begin-for-syntax (begin-for-syntax
(define-syntax-rule (with-shared-id (id ...) . body) (define-syntax-rule (with-shared-id (id ...) . body)
(with-syntax ([id (shared-syntax 'id)] ...) (with-syntax ([id (shared-syntax 'id)] ...)
. body)) . body))
(define-syntax with-calling-site-id (make-rename-transformer #'with-shared-id))) (define-syntax with-calling-site-id (make-rename-transformer #'with-shared-id)))
(define-syntax (define-macro stx)
;; `syntax-parse` classes shared by `define-macro` and `define-macro-cases`
(begin-for-syntax
(require syntax/parse)
(define-syntax-class syntaxed-id (define-syntax-class syntaxed-id
#:literals (syntax) #:literals (syntax quasisyntax)
#:description "id in syntaxed form" #:description "id in syntaxed form"
(pattern (syntax name:id))) (pattern ([~or syntax quasisyntax] name:id)))
(define-syntax-class syntaxed-thing (define-syntax-class syntaxed-thing
#:literals (syntax) #:literals (syntax quasisyntax)
#:description "some datum in syntaxed form" #:description "some datum in syntaxed form"
(pattern (syntax thing:expr))) (pattern ([~or syntax quasisyntax] thing:expr)))
(define-syntax-class else-clause
#:literals (else)
(pattern [else . body:expr]))
(define-syntax-class transformer-func (define-syntax-class transformer-func
#:literals (lambda λ) #:literals (lambda λ)
(pattern ([~or lambda λ] (arg:id) . body:expr))) (pattern ([~or lambda λ] (arg:id) . body:expr))))
(define-syntax (define-macro stx)
(syntax-parse stx (syntax-parse stx
#:literals (syntax) [(_ id:id stxed-id:syntaxed-id)
[(_ id:id sid:syntaxed-id) #'(define-syntax id (make-rename-transformer stxed-id))]
#'(define-syntax id (make-rename-transformer sid))]
[(_ id:id func:transformer-func) [(_ id:id func:transformer-func)
#'(define-syntax id func)] #'(define-syntax id func)]
[(_ id:id thing:syntaxed-thing) [(_ id:id stxed-thing:syntaxed-thing)
#'(define-syntax id (λ(stx) thing))] #'(define-macro id (λ (stx) stxed-thing))]
[(_ (id:id . patargs) . body:expr) [(_ (id:id . patargs:expr) . body:expr)
#'(define-macro-cases id [(id . patargs) (begin . body)])])) #'(define-macro-cases id [(id . patargs) (begin . body)])]
[else (raise-syntax-error
'define-macro
"no matching case for calling pattern"
(syntax->datum stx))]))
(define-syntax (define-macro-cases stx) (define-syntax (define-macro-cases stx)
(define-syntax-class syntaxed-id
#:literals (syntax)
#:description "id in syntaxed form"
(pattern (syntax name:id)))
(define-syntax-class syntaxed-thing
#:literals (syntax)
#:description "some datum in syntaxed form"
(pattern (syntax thing:expr)))
(syntax-parse stx (syntax-parse stx
#:literals (syntax) [(_ id:id)
[(_ id:id) ; defective for syntax
(raise-syntax-error 'define-macro-cases "no cases given" (syntax->datum #'id))] (raise-syntax-error 'define-macro-cases "no cases given" (syntax->datum #'id))]
[(_ id:id . patexprs) [(_ id:id leading-pat:expr ... else-pat:else-clause trailing-pat0:expr trailing-pat:expr ...)
;; todo: rephrase this check as a syntax-parse pattern above (raise-syntax-error 'define-macro-cases "`else` clause must be last" (syntax->datum #'id))]
(let ([all-but-last-pat-datums (map syntax->datum (syntax->list (syntax-case #'patexprs () [(_ id:id (pat:expr . result-exprs:expr) ... else-clause:else-clause)
[((pat result) ... last-one) #'(pat ...)])))]) (with-syntax ([LITERALS (generate-literals #'(pat ...))])
(when (member 'else all-but-last-pat-datums) #'(define-macro id
(raise-syntax-error 'define-cases "else case must be last" (syntax->datum #'id))))
(with-syntax* ([((pat . result-exprs) ... else-result-exprs)
(syntax-parse #'patexprs
#:literals (syntax else)
;; syntax notation on pattern is optional
[(((~or (syntax pat) pat) result-expr) ... (else . else-result-exprs))
#'((pat result-expr) ... else-result-exprs)]
[(((~or (syntax pat) pat) result-expr) ...)
#'((pat result-expr) ... (list (raise-syntax-error 'define-cases (format "no matching case for syntax pattern ~v" (syntax->datum stx)) (syntax->datum #'id))))])]
[LITERALS (generate-literals #'(pat ...))])
#'(define-syntax id
(λ (stx) (λ (stx)
(define result (define result
(syntax-case stx LITERALS (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
[pat (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)]) (syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)])
(syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)]) (syntax-case stx LITERALS
. result-exprs))] ... [pat . result-exprs] ...
[else . else-result-exprs])) else-clause))))
(if (syntax? result) (if (syntax? result)
result result
(datum->syntax #'id result)))))])) (datum->syntax #'id result)))))]
[(_ id:id pat-clause:expr ...) ; macro without `else` clause will reach this branch
#'(define-macro-cases id
pat-clause ...
[else (raise-syntax-error
'id
"no matching case for calling pattern"
(syntax->datum caller-stx))])]
[else (raise-syntax-error
'define-macro-cases
"no matching case for calling pattern"
(syntax->datum stx))]))
(module+ test (module+ test
@ -189,11 +198,11 @@
(define-macro plusser #'plus) (define-macro plusser #'plus)
(check-equal? (plusser 42) +) (check-equal? (plusser 42) +)
(check-equal? plusser +) (check-equal? plusser +)
(define-macro (times [nested ARG]) #'(* ARG ARG)) (define-macro (times [nested ARG]) #`(* ARG ARG))
(check-equal? (times [nested 10]) 100) (check-equal? (times [nested 10]) 100)
(define-macro timeser #'times) (define-macro timeser #'times)
(check-equal? (timeser [nested 12]) 144) (check-equal? (timeser [nested 12]) 144)
(define-macro fortytwo #'42) (define-macro fortytwo #`42)
(check-equal? fortytwo 42) (check-equal? fortytwo 42)
(check-equal? (let () (check-equal? (let ()
(define-macro (foo X) (define-macro (foo X)
@ -243,5 +252,9 @@
(check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases no-cases)))) (check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases no-cases))))
(check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases badelseop (check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases badelseop
[else #''got-else] [else #''got-else]
[(_ _arg) #''got-arg]))))) [(_ _arg) #''got-arg]))))
(define-macro-cases no-else-macro
[(_ ARG) #''got-arg])
(check-exn exn:fail:syntax? (λ _ (expand-once #'(no-else-macro 'arg1 'arg2)))))
Write Preview
Loading…
Cancel
Save