From 2912d8392f55c19c49a0a029822b4070a98953e7 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 3 Apr 2018 22:37:58 -0700 Subject: [PATCH] handle pair patterns --- beautiful-racket-lib/br/define.rkt | 7 ------- .../br/private/generate-literals.rkt | 21 +++++++++++++++++-- 2 files changed, 19 insertions(+), 9 deletions(-) diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index 5b7e528..cd84750 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/beautiful-racket-lib/br/define.rkt @@ -135,13 +135,6 @@ "no matching case for calling pattern" (syntax->datum stx))])) -(define-for-syntax (literalize-pat pat) - (cond - [(syntax->list pat) => (λ (subpats) (datum->syntax pat (map literalize-pat subpats)))] - [else (syntax-case pat () - [pat (and (identifier? #'pat) (literal-identifier-datum? (syntax->datum #'pat))) - #'(~literal pat)] - [pat #'pat])])) (define-syntax (define-macro-cases stx) (define (error-source stx) (or (syntax-property stx 'caller) 'define-macro-cases)) diff --git a/beautiful-racket-lib/br/private/generate-literals.rkt b/beautiful-racket-lib/br/private/generate-literals.rkt index 0903869..05611c6 100644 --- a/beautiful-racket-lib/br/private/generate-literals.rkt +++ b/beautiful-racket-lib/br/private/generate-literals.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require "syntax-flatten.rkt" racket/list racket/match) -(provide ellipses-follow-wildcards-or-subpatterns? generate-literals generate-bound-and-unbound-literals literal-identifier-datum?) +(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) (define (literal-identifier-datum? pat-datum) (and (symbol? pat-datum) @@ -9,6 +9,23 @@ (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 (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)) + (check-equal? (syntax->datum (literalize-pat #'(hello . WORLD))) '((~literal hello) . WORLD)) + (check-equal? (syntax->datum (literalize-pat #'(hello WORLD (... ...)))) '((~literal hello) WORLD ...)) + (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))