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 0ce28acafd
commit 9a1b621969
1 changed files with 59 additions and 96 deletions
Show Stats Download Patch File Download Diff File

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

@ -48,40 +48,11 @@
(syntax-parse stx
#:literals (syntax)
;; defective for syntax or function
;; defective for function
[(_ top-id)
(raise-syntax-error 'define-cases "no cases given" (syntax->datum #'top-id))]
;; defective for syntax
[(_ (sid:syntaxed-id . _) . _) ; (define (#'f1 stx) expr ...)
(raise-syntax-error 'define-cases "definition of a syntax transformer must use lambda notation, because otherwise it's too easy to confuse the compile-time shape and the run-time shape" (syntax->datum #'sid.name))]
;; syntax matcher
[(_ top-id:syntaxed-id . patexprs)
;; todo: rephrase this check as a syntax-parse pattern above
(let ([all-but-last-pat-datums (map syntax->datum (syntax->list (syntax-case #'patexprs ()
[((pat result) ... last-one) #'(pat ...)])))])
(when (member 'else all-but-last-pat-datums)
(raise-syntax-error 'define-cases "else case must be last" (syntax->datum #'top-id.name))))
(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 #'top-id.name))))])]
[LITERALS (generate-literals #'(pat ...))])
#'(define-syntax top-id.name (λ (stx)
(define result
(syntax-case stx LITERALS
[pat (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
(syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)])
. result-exprs))] ...
[else . else-result-exprs]))
(if (syntax? result)
result
(datum->syntax #'top-id.name result)))))]
;; function matcher
[(_ top-id:id [(_ . pat-args) . body] ...)
@ -99,45 +70,6 @@
(check-equal? (f 42 5) 47))
(define-syntax (br:define stx)
;;todo: share syntax classes
(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
#:literals (syntax)
;; syntax
[(_ (syntax (id . pat-args)) . body) ; (define #'(foo arg) #'(+ arg arg))
#'(define-cases (syntax id) [(syntax (_ . pat-args)) (begin . body)])]
[(_ sid:syntaxed-id sid2:syntaxed-id) ; (define #'f1 #'f2)
#'(define-syntax sid.name (make-rename-transformer sid2))]
[(_ (syntax id) (syntax thing)) ; (define #'f1 #'42)
#'(define-cases (syntax id) [#'_ (syntax thing)])]
[(_ (sid:syntaxed-id stx-arg ...) . exprs) ; (define (#'f1 stx) expr ...)
(raise-syntax-error 'define "definition of a syntax transformer must use lambda notation, because otherwise it's too easy to confuse the compile-time shape and the run-time shape" (syntax->datum #'sid.name))]
[(_ sid:syntaxed-id (λ (stx-arg ...) . exprs)) ; (define #'f1 (λ(stx) expr ...)
#:fail-when (not (= (length (syntax->datum #'(stx-arg ...))) 1))
(raise-syntax-error 'define "did not get exactly one argument for macro" (syntax->datum #'(stx-arg ...)))
(with-syntax ([(first-stx-arg other ...) #'(stx-arg ...)])
#'(define-syntax (sid.name first-stx-arg) . exprs))]
[(_ . args) #'(define . args)]))
(define-syntax-rule (debug-define-macro (id . pat-args) body-exp)
(define-macro (id . pat-args)
#`(begin
@ -167,14 +99,12 @@
(begin-for-syntax
(begin-for-syntax
(require (for-syntax racket/base))
(define-syntax (make-shared-syntax-macro stx)
(syntax-case stx ()
[(_ caller-stx)
#'(λ(stx) (syntax-case stx ()
(define-syntax-rule (make-shared-syntax-macro caller-stx)
#'(syntax-rules stx
[(_ form)
#'(datum->syntax caller-stx (if (syntax? form)
(syntax-e form)
form))]))]))))
form))]))))
(begin-for-syntax
(define-syntax-rule (with-shared-id (id ...) . body)
@ -194,14 +124,21 @@
#:description "some datum in syntaxed form"
(pattern (syntax thing:expr)))
(define-syntax-class transformer-func
#:literals (lambda λ)
(pattern ([~or lambda λ] (arg:id) . body:expr)))
(syntax-parse stx
#:literals (syntax)
[(_ id #'other-id) ; (define-macro id #'other-id)
#'(br:define #'id #'other-id)]
[(_ (id . patargs) . body)
#'(br:define #'(id . patargs) . body)]
[(_ id [pat . patbody] ...)
#'(define-cases (syntax id) [pat . patbody] ...)]))
[(_ id:id sid:syntaxed-id)
#'(define-syntax id (make-rename-transformer sid))]
[(_ id:id func:transformer-func)
#'(define-syntax id func)]
[(_ id:id thing:syntaxed-thing)
#'(define-syntax id (λ(stx) thing))]
[(_ (id:id . patargs) . body:expr)
#'(define-macro-cases id [(id . patargs) (begin . body)])]))
(define-syntax (define-macro-cases stx)
(define-syntax-class syntaxed-id
@ -216,17 +153,42 @@
(syntax-parse stx
#:literals (syntax)
[(_ id . body)
#'(define-cases (syntax id) . body)]))
[(_ id:id) ; defective for syntax
(raise-syntax-error 'define-macro-cases "no cases given" (syntax->datum #'id))]
[(_ id:id . patexprs)
;; todo: rephrase this check as a syntax-parse pattern above
(let ([all-but-last-pat-datums (map syntax->datum (syntax->list (syntax-case #'patexprs ()
[((pat result) ... last-one) #'(pat ...)])))])
(when (member 'else all-but-last-pat-datums)
(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)
(define result
(syntax-case stx LITERALS
[pat (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
(syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)])
. result-exprs))] ...
[else . else-result-exprs]))
(if (syntax? result)
result
(datum->syntax #'id result)))))]))
(module+ test
;; todo: make these tests work, if they still make sense
#;(define-macro plus (λ(stx) #'+))
#;(check-equal? (plus 42) +)
#;(define-macro plusser #'plus)
#;(check-equal? (plusser 42) +)
#;(check-equal? plusser +)
(define-macro plus (λ(stx) #'+))
(check-equal? (plus 42) +)
(define-macro plusser #'plus)
(check-equal? (plusser 42) +)
(check-equal? plusser +)
(define-macro (times [nested ARG]) #'(* ARG ARG))
(check-equal? (times [nested 10]) 100)
(define-macro timeser #'times)
@ -254,7 +216,7 @@
(check-equal? (add 5) 10)
(define-macro-cases add-again [(_ X) #'(+ X X)])
(check-equal? (add-again 5) 10)
(define-macro add-3rd [(_ X) #'(+ X X)])
(define-macro-cases add-3rd [(_ X) #'(+ X X)])
(check-equal? (add-3rd 5) 10)
(define-macro add-4th #'add-3rd)
(check-equal? (add-4th 5) 10)
@ -278,7 +240,8 @@
(check-equal? (elseop "+") 'got-arg)
(check-equal? (elseop "+" 42) 'got-else)
;; todo: fix test, should throw error because `else` clause is out of order
#;(check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases badelseop
(check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases no-cases))))
(check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases badelseop
[else #''got-else]
[(_ _arg) #''got-arg])))))
Write Preview
Loading…
Cancel
Save