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

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

@ -48,40 +48,11 @@
(syntax-parse stx (syntax-parse stx
#:literals (syntax) #:literals (syntax)
;; defective for syntax or function ;; defective for function
[(_ top-id) [(_ top-id)
(raise-syntax-error 'define-cases "no cases given" (syntax->datum #'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 ;; function matcher
[(_ top-id:id [(_ . pat-args) . body] ...) [(_ top-id:id [(_ . pat-args) . body] ...)
@ -99,45 +70,6 @@
(check-equal? (f 42 5) 47)) (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-syntax-rule (debug-define-macro (id . pat-args) body-exp)
(define-macro (id . pat-args) (define-macro (id . pat-args)
#`(begin #`(begin
@ -167,14 +99,12 @@
(begin-for-syntax (begin-for-syntax
(begin-for-syntax (begin-for-syntax
(require (for-syntax racket/base)) (require (for-syntax racket/base))
(define-syntax (make-shared-syntax-macro stx) (define-syntax-rule (make-shared-syntax-macro caller-stx)
(syntax-case stx () #'(syntax-rules stx
[(_ caller-stx) [(_ form)
#'(λ(stx) (syntax-case stx () #'(datum->syntax caller-stx (if (syntax? form)
[(_ form) (syntax-e form)
#'(datum->syntax caller-stx (if (syntax? form) form))]))))
(syntax-e form)
form))]))]))))
(begin-for-syntax (begin-for-syntax
(define-syntax-rule (with-shared-id (id ...) . body) (define-syntax-rule (with-shared-id (id ...) . body)
@ -184,7 +114,7 @@
(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) (define-syntax (define-macro stx)
(define-syntax-class syntaxed-id (define-syntax-class syntaxed-id
#:literals (syntax) #:literals (syntax)
#:description "id in syntaxed form" #:description "id in syntaxed form"
(pattern (syntax name:id))) (pattern (syntax name:id)))
@ -193,18 +123,25 @@
#:literals (syntax) #:literals (syntax)
#:description "some datum in syntaxed form" #:description "some datum in syntaxed form"
(pattern (syntax thing:expr))) (pattern (syntax thing:expr)))
(define-syntax-class transformer-func
#:literals (lambda λ)
(pattern ([~or lambda λ] (arg:id) . body:expr)))
(syntax-parse stx (syntax-parse stx
#:literals (syntax) #:literals (syntax)
[(_ id #'other-id) ; (define-macro id #'other-id) [(_ id:id sid:syntaxed-id)
#'(br:define #'id #'other-id)] #'(define-syntax id (make-rename-transformer sid))]
[(_ (id . patargs) . body) [(_ id:id func:transformer-func)
#'(br:define #'(id . patargs) . body)] #'(define-syntax id func)]
[(_ id [pat . patbody] ...) [(_ id:id thing:syntaxed-thing)
#'(define-cases (syntax id) [pat . patbody] ...)])) #'(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 (define-macro-cases stx)
(define-syntax-class syntaxed-id (define-syntax-class syntaxed-id
#:literals (syntax) #:literals (syntax)
#:description "id in syntaxed form" #:description "id in syntaxed form"
(pattern (syntax name:id))) (pattern (syntax name:id)))
@ -216,17 +153,42 @@
(syntax-parse stx (syntax-parse stx
#:literals (syntax) #:literals (syntax)
[(_ id . body) [(_ id:id) ; defective for syntax
#'(define-cases (syntax id) . body)])) (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 (module+ test
;; todo: make these tests work, if they still make sense (define-macro plus (λ(stx) #'+))
#;(define-macro plus (λ(stx) #'+)) (check-equal? (plus 42) +)
#;(check-equal? (plus 42) +) (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)
@ -254,7 +216,7 @@
(check-equal? (add 5) 10) (check-equal? (add 5) 10)
(define-macro-cases add-again [(_ X) #'(+ X X)]) (define-macro-cases add-again [(_ X) #'(+ X X)])
(check-equal? (add-again 5) 10) (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) (check-equal? (add-3rd 5) 10)
(define-macro add-4th #'add-3rd) (define-macro add-4th #'add-3rd)
(check-equal? (add-4th 5) 10) (check-equal? (add-4th 5) 10)
@ -278,7 +240,8 @@
(check-equal? (elseop "+") 'got-arg) (check-equal? (elseop "+") 'got-arg)
(check-equal? (elseop "+" 42) 'got-else) (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 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])))))
Write Preview
Loading…
Cancel
Save