From 86b788a30492774d8ee08dc8a17946fa222b2026 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 4 Apr 2018 12:08:48 -0700 Subject: [PATCH] further simplify literalization --- beautiful-racket-lib/br/define.rkt | 2 +- .../br/private/generate-literals.rkt | 92 ++++++------------- beautiful-racket-lib/br/syntax.rkt | 69 ++++++++++---- 3 files changed, 80 insertions(+), 83 deletions(-) diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index cd84750..fcc90ae 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/beautiful-racket-lib/br/define.rkt @@ -146,7 +146,7 @@ [(_ id:id (pat:expr . result-exprs:expr) ... else-clause:else-clause) (unless (ellipses-follow-wildcards-or-subpatterns? #'(pat ...)) (raise-syntax-error (error-source #'id) "ellipsis in pattern can only appear after wildcard or subpattern" (syntax->datum stx))) - (with-syntax ([(PAT ...) (map literalize-pat (syntax->list #'(pat ...)))]) + (with-syntax ([(PAT ...) (map (λ (x) (literalize-pat x #'~literal)) (syntax->list #'(pat ...)))]) #'(define-macro id (λ (stx) (define result diff --git a/beautiful-racket-lib/br/private/generate-literals.rkt b/beautiful-racket-lib/br/private/generate-literals.rkt index 05611c6..5c3ba5c 100644 --- a/beautiful-racket-lib/br/private/generate-literals.rkt +++ b/beautiful-racket-lib/br/private/generate-literals.rkt @@ -1,23 +1,32 @@ #lang racket/base (require "syntax-flatten.rkt" racket/list racket/match syntax/parse) -(provide ellipses-follow-wildcards-or-subpatterns? generate-literals generate-bound-and-unbound-literals literalize-pat) +(provide ellipses-follow-wildcards-or-subpatterns? literalize-pat) -(define (literal-identifier-datum? pat-datum) - (and (symbol? pat-datum) - (not (memq pat-datum '(... _))) ; isn't a reserved identifier - (let ([pat-str (symbol->string pat-datum)]) - (or (not (regexp-match #rx"[A-Z]" pat-str)) ; either doesn't contain at least one uppercase letter ... - (not (equal? (string-upcase pat-str) pat-str)))))) ;... or doesn't contain all uppercase letters +(define (literal-identifier? x) + (let ([x (if (syntax? x) (syntax-e x) x)]) + (and (symbol? x) + (not (memq x '(... _))) ; isn't a reserved identifier + (let ([pat-str (symbol->string x)]) + (or (not (regexp-match #rx"[A-Z]" pat-str)) ; either doesn't contain at least one uppercase letter ... + (not (equal? (string-upcase pat-str) pat-str))))))) ;... or doesn't contain all uppercase letters + + +(define (wildcard-datum? x) (and (symbol? x) (not (literal-identifier? x)))) + + +(define (literalize-pat pat [literalizer-id #'~literal]) + ;; take `literalizer-id` as explicit input from the calling site + ;; because this is a macro helper + ;; so hygiene is not enforced + (let loop ([pat pat]) + (syntax-case pat () + [(HEAD . TAIL) (datum->syntax pat (cons (loop #'HEAD) (loop #'TAIL)))] + [MAYBE-LIT-ID (literal-identifier? #'MAYBE-LIT-ID) + (with-syntax ([literalizer-id literalizer-id] + [lit-id #'MAYBE-LIT-ID]) + #'(literalizer-id lit-id))] + [ANY #'ANY]))) -(define (literalize-pat pat) - (cond - [(syntax->list #'pat) => (λ (subpats) (datum->syntax pat (map literalize-pat subpats)))] - [else - (syntax-case pat () - [(head . tail) (datum->syntax pat (cons (literalize-pat #'head) (literalize-pat #'tail)))] - [pat (and (identifier? #'pat) (literal-identifier-datum? (syntax->datum #'pat))) - #'(~literal pat)] - [pat #'pat])])) (module+ test (check-equal? (syntax->datum (literalize-pat #'(hello WORLD))) '((~literal hello) WORLD)) @@ -26,44 +35,6 @@ (check-equal? (syntax->datum (literalize-pat #'(hello (cruel WORLD)))) '((~literal hello) ((~literal cruel) WORLD))) (check-equal? (syntax->datum (literalize-pat #'(hello (cruel . WORLD)))) '((~literal hello) ((~literal cruel) . WORLD)))) -(define (wildcard? pat-datum) - (and (symbol? pat-datum) - (not (literal-identifier-datum? pat-datum)) - (not (memq pat-datum '(... _))))) - -;; generate literals for any symbols that are not ... or _ and not IN_CAPS -(define (generate-literals pats) - (for*/list ([pat-arg (in-list (syntax-flatten pats))] - [pat-datum (in-value (syntax->datum pat-arg))] - #:when (literal-identifier-datum? pat-datum)) - pat-arg)) - - -(define (generate-bound-and-unbound-literals pats #:treat-as-bound [bound-id #f]) - (when (and bound-id (not (identifier? bound-id))) - (raise-argument-error 'generate-bound-and-unbound-literals "identifier" bound-id)) - (define literals (for/list ([literal (in-list (generate-literals pats))] - ; the bound-id should not appear in any literal list - #:unless (and bound-id (bound-identifier=? literal bound-id))) - literal)) - (define-values (bound-literals unbound-literals) - (partition (λ (i) (or (identifier-binding i) - (and bound-id (bound-identifier=? i bound-id)))) literals)) - ;; return as list of two lists so it's easy to match them in syntax pattern - ;; `syntax-parse` crabs if there are any duplicate ids, so remove them - (map (λ (ids) (remove-duplicates ids bound-identifier=?)) (list bound-literals unbound-literals))) - - -(module+ test - (define b-id 42) - (match-let ([(list bs ubs) (generate-bound-and-unbound-literals #'(ub-id b-id FOO))]) - (check-equal? (map syntax->datum bs) '(b-id)) - (check-equal? (map syntax->datum ubs) '(ub-id))) - (match-let ([(list bs ubs) (generate-bound-and-unbound-literals #'(ub-id b-id FOO) #:treat-as-bound #'ub-id)]) - (check-equal? (map syntax->datum bs) '(b-id)) - (check-equal? (map syntax->datum ubs) '())) - (check-exn exn:fail:contract? (λ () (generate-bound-and-unbound-literals #'(ub-id b-id FOO) #:treat-as-bound 42)))) - (define (ellipses-follow-wildcards-or-subpatterns? pat) (let loop ([datum (syntax->datum pat)]) @@ -71,7 +42,7 @@ [(? null?) #t] [(cons '... _) #f] [(cons _ '...) #f] - [(list head '... tail ...) (and (or (wildcard? head) (pair? head)) + [(list head '... tail ...) (and (or (wildcard-datum? head) (pair? head)) (loop head) (loop tail))] [(list head tail ...) (and (loop head) (loop tail))] @@ -81,14 +52,11 @@ (module+ test (require rackunit) - (check-equal? (map syntax->datum (generate-literals #'(foo 42 BAR _ (... ...) bar <=> 3Bar 3bar))) '(foo bar <=> 3Bar 3bar)) - (test-case "wildcard-identifier?" - (check-true (wildcard? 'FOO)) - (check-true (wildcard? 'TOPPING)) - - (check-false (wildcard? 'piZZa)) - (check-false (wildcard? 'please))) + (check-true (wildcard-datum? 'FOO)) + (check-true (wildcard-datum? 'TOPPING)) + (check-false (wildcard-datum? 'piZZa)) + (check-false (wildcard-datum? 'please))) (test-case "all-...-follow-wildcards" (check-true (ellipses-follow-wildcards-or-subpatterns? #'())) diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index 8c74776..877e053 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/beautiful-racket-lib/br/syntax.rkt @@ -22,8 +22,36 @@ [suffix-id suffix-ids] [infix-id infix-ids])) +(module+ test (require rackunit)) + + +(define-macro-cases syntax-parse/easy + [(_ STX [PAT . BODY] ... [else . ELSEBODY]) + (with-syntax ([(PAT ...) (map (λ (stx) (literalize-pat stx #'~literal)) (syntax->list #'(PAT ...)))]) + #'(syntax-parse (syntax-case STX () [any #'any]) + [PAT . BODY] ... [else . ELSEBODY]))]) + + +(define-macro-cases pattern-case + [(_ EXPR ... [else . ELSEBODY]) #'(syntax-parse/easy EXPR ... + [else . ELSEBODY])] + [(_ STX-ARG PAT+BODY ...) + #'(pattern-case STX-ARG + PAT+BODY ... + [else (raise-syntax-error 'pattern-case + (format "unable to match pattern for ~v" (syntax->datum STX-ARG)))])]) + (module+ test - (require rackunit)) + (define (pc stx) + (pattern-case stx + [(a 2ND c) #'2ND] + [(LEFT RIGHT) #'LEFT] + [(g) #'hooray])) + (check-equal? (syntax->datum (pc #'(a b c))) 'b) + (check-equal? (syntax->datum (pc #'(x y))) 'x) + (check-equal? (syntax->datum (pc #'(g))) 'hooray) + (check-exn exn:fail:syntax? (λ () (pc #'(f))))) + (define-macro (pattern-case-filter STX-ARG PAT+BODY ...) #'(let* ([arg STX-ARG] @@ -34,36 +62,37 @@ (for*/list ([stx (in-list stxs)] [result (in-value (pattern-case stx PAT+BODY ... [else #f]))] #:when result) - result))) + result))) -(define-macro (syntax-parse/easy STX LITS . EXPS) - (with-syntax ([(BOUND-LITS UNBOUND-LITS) (generate-bound-and-unbound-literals #'LITS)]) - #'(syntax-parse (syntax-case STX () [any #'any]) - #:literals BOUND-LITS - #:datum-literals UNBOUND-LITS - . EXPS))) +(module+ test + (define (pcf x) + (pattern-case-filter x + [(1ST 2ND 3RD) #'2ND] + [(LEFT RIGHT) #'LEFT])) + (check-equal? (map syntax-e (pcf #'((a b c) (x y) (f)))) '(b x))) -(define-macro-cases pattern-case - [(_ STX-ARG - [PAT . BODY] ... - [else . ELSEBODY]) #'(syntax-parse/easy STX-ARG (PAT ...) - [PAT . BODY] ... - [else . ELSEBODY])] - [(_ STX-ARG PAT+BODY ...) - #'(pattern-case STX-ARG - PAT+BODY ... - [else (raise-syntax-error 'pattern-case - (format "unable to match pattern for ~v" (syntax->datum STX-ARG)))])]) (define-macro-cases with-pattern [(_ () . BODY) #'(begin . BODY)] [(_ ([PAT0 STX0] PAT+STX ...) . BODY) - #'(syntax-parse/easy STX0 PAT0 + #'(syntax-parse/easy STX0 [PAT0 (with-pattern (PAT+STX ...) (let () (void) . BODY))] [else (raise-syntax-error 'with-pattern (format "unable to match pattern ~a" 'PAT0) STX0)])]) +(module+ test + (check-equal? (syntax->datum (with-pattern ([foo 'foo]) + #'zzz)) 'zzz) + (check-exn exn:fail:syntax? (λ () (with-pattern ([42 'foo]) + #'zzz))) + (check-exn exn:fail:syntax? (λ () (with-pattern ([bar 'foo]) + #'zzz))) + (check-equal? (syntax->datum (with-pattern ([(foo BAR) '(foo 42)]) + #'BAR)) 42) + (check-exn exn:fail:syntax? (λ () (with-pattern ([(foo BAR) '(zam 42)]) + #'BAR)))) + (define-macro (format-string FMT ID0 ID ...) #'(datum->syntax ID0 (format FMT (syntax->datum ID0) (syntax->datum ID) ...)))