further simplify literalization

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

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)])
+(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
+               (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
+
+(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 (literalize-pat #'head) (literalize-pat #'tail)))]
-       [pat (and (identifier? #'pat) (literal-identifier-datum? (syntax->datum #'pat)))
-            #'(~literal pat)]
-       [pat #'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])))
+
 
 (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? #'()))

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]
@@ -37,33 +65,34 @@
         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) ...)))