handle pair patterns

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))

beautiful-racket-lib/br/private/generate-literals.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
-(require "syntax-flatten.rkt" racket/list racket/match)
+(require "syntax-flatten.rkt" racket/list racket/match syntax/parse)
-(provide ellipses-follow-wildcards-or-subpatterns? generate-literals generate-bound-and-unbound-literals literal-identifier-datum?)
+(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))