From c43a486f9d59d54065bd361329a8d24bd010fa66 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 1 Feb 2017 14:40:35 -0800 Subject: [PATCH] add literal generator to `with-pattern` --- beautiful-racket-demo/basic-demo/expander.rkt | 2 +- beautiful-racket-lib/br/cond.rkt | 7 +++--- beautiful-racket-lib/br/define.rkt | 24 +++---------------- .../br/private/generate-literals.rkt | 20 ++++++++++++++++ beautiful-racket-lib/br/syntax.rkt | 16 ++++++++----- 5 files changed, 37 insertions(+), 32 deletions(-) create mode 100644 beautiful-racket-lib/br/private/generate-literals.rkt diff --git a/beautiful-racket-demo/basic-demo/expander.rkt b/beautiful-racket-demo/basic-demo/expander.rkt index 5449242..745c9af 100644 --- a/beautiful-racket-demo/basic-demo/expander.rkt +++ b/beautiful-racket-demo/basic-demo/expander.rkt @@ -9,7 +9,7 @@ (define-macro (b-module-begin (b-program LINE ...)) (with-pattern - ([((NAME NUM STMT ...) ...) #'(LINE ...)] + ([((b-line NUM STMT ...) ...) #'(LINE ...)] [(LINE-FUNC ...) (prefix-id "line-" #'(NUM ...))]) #'(#%module-begin LINE ... diff --git a/beautiful-racket-lib/br/cond.rkt b/beautiful-racket-lib/br/cond.rkt index 6043fb7..6e2d3b1 100644 --- a/beautiful-racket-lib/br/cond.rkt +++ b/beautiful-racket-lib/br/cond.rkt @@ -18,10 +18,9 @@ (define-macro (forever . EXPRS) ;; todo: would be better with a syntax parameter (with-pattern - ([stop (datum->syntax #'EXPRS 'stop)]) - #'(let/ec stop - (while #t - . EXPRS)))) + ([STOP (datum->syntax #'EXPRS 'stop)]) + #'(let/ec STOP + (while #t . EXPRS)))) (module+ test (require rackunit) diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index 190e8fe..4faba7c 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/beautiful-racket-lib/br/define.rkt @@ -4,6 +4,7 @@ (for-syntax racket/base syntax/parse br/private/syntax-flatten + br/private/generate-literals syntax/define)) (provide (all-defined-out) (for-syntax with-shared-id)) @@ -21,25 +22,6 @@ (provide id) (define id lambda-exp)))) - -(begin-for-syntax - (define (upcased-and-capitalized? sym) - (define str (symbol->string sym)) - (and (equal? (string-upcase str) str) - (let ([first-letter (substring str 0 1)]) - (or (and (string->number first-letter) #t) ; leading digit OK - (not (equal? (string-downcase first-letter) first-letter)))))) - - (define (generate-literals pats) - ;; generate literals for any symbols that are not ... or _ - (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 '(... _))) ; exempted from literality - (not (upcased-and-capitalized? 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) @@ -173,12 +155,12 @@ [(_ id:id leading-pat:expr ... else-pat:else-clause trailing-pat0:expr trailing-pat:expr ...) (raise-syntax-error 'define-macro-cases "`else` clause must be last" (syntax->datum #'id))] [(_ id:id (pat:expr . result-exprs:expr) ... else-clause:else-clause) - (with-syntax ([LITERALS (generate-literals #'(pat ...))]) + (with-syntax ([(LITERAL ...) (generate-literals #'(pat ...))]) #'(define-macro id (λ (stx) (define result (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)]) - (syntax-case stx LITERALS + (syntax-case stx (LITERAL ...) [pat . result-exprs] ... else-clause))) (if (syntax? result) diff --git a/beautiful-racket-lib/br/private/generate-literals.rkt b/beautiful-racket-lib/br/private/generate-literals.rkt new file mode 100644 index 0000000..a43a42f --- /dev/null +++ b/beautiful-racket-lib/br/private/generate-literals.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require racket/list "syntax-flatten.rkt") +(provide (all-defined-out)) + +(define (upcased-and-capitalized? sym) + (define str (symbol->string sym)) + (and (equal? (string-upcase str) str) + (let ([first-letter (substring str 0 1)]) + (or (and (string->number first-letter) #t) ; leading digit OK + (not (equal? (string-downcase first-letter) first-letter)))))) + + (define (generate-literals pats) + ;; generate literals for any symbols that are not ... or _ + (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 '(... _))) ; exempted from literality + (not (upcased-and-capitalized? pat-datum)))) + pat-arg)) \ No newline at end of file diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index 9ad9353..2c958fc 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/beautiful-racket-lib/br/syntax.rkt @@ -1,5 +1,8 @@ #lang racket/base -(require (for-syntax racket/base racket/syntax) +(require (for-syntax + racket/base + racket/syntax + br/private/generate-literals) racket/list racket/match racket/syntax @@ -30,11 +33,12 @@ (define-macro-cases with-pattern [(_ () . BODY) #'(begin . BODY)] - [(_ ([SID SID-STX] STX ...) . BODY) - #'(with-syntax ([SID SID-STX]) - (with-pattern (STX ...) . BODY))] - [(_ ([SID] STX ...) . BODY) ; standalone id - #'(with-pattern ([SID SID] STX ...) . BODY)]) ; convert to previous case + [(_ ([PAT STX] PAT+STX ...) . BODY) + (with-syntax ([(LITERAL ...) (generate-literals #'PAT)]) + #'(syntax-case STX (LITERAL ...) + [PAT (with-pattern (PAT+STX ...) (let () . BODY))]))] + [(_ ([ID] STX ...) . BODY) ; standalone id + #'(with-pattern ([ID ID] STX ...) . BODY)]) ; convert to previous case (define (check-syntax-list-argument caller-name arg)