Recursive pattern expander for Racket

recursive-pattern.rkt

#lang racket
(require (for-syntax syntax/parse)
         (for-meta 2 racket syntax/parse syntax/stx racket/syntax))

(begin-for-syntax
  (begin-for-syntax

    ;; attr+arity ::= id
    ;;              | [id arity]
    ;;
    ;; attr-arity-decl from syntax/parse docs
    (define-syntax-class attr+arity
      [pattern id:id #:with arity 0]
      [pattern [id:id arity:nat]])

    ;; Syntax Nat -> Syntax
    ;; wraps 'stx' in (_ ...) 'n' times.
    (define (arity->dots* stx n)
      (cond
        [(syntax? n) (arity->dots* stx (syntax-e n))]
        [(zero? n) stx]
        [else (quasisyntax/loc stx
                (#,(arity->dots* stx (sub1 n))
                 (... ...)))])))

  ;; {~rec placeholder-id
  ;;       #:binds (attr-arity-decl ...)
  ;;       pattern}
  ;;
  ;; pattern expander that matches the given pattern, recurring on
  ;; wherever the placeholder is matched in the pattern. each variable
  ;; listed in #:binds is bound with ellipsis depth 1 more than specified,
  ;; listing each occurence.
  ;;
  ;; e.g.
  ;;   > (syntax-parse #'(a (b (c (d (e f)))))
  ;;       [(~rec R #:binds (l) (l R))
  ;;        (values (syntax->datum #'[l ...])
  ;;                (syntax->datum #'R))])
  ;;   '(a b c d e)
  ;;   'f
  ;;
  (define-syntax ~rec
    (pattern-expander
     (syntax-parser
       [(_ PH:id
           {~or {~seq #:binds (attr:attr+arity ...)}
                {~seq {~parse (attr:attr+arity ...) #'[]}}}
           pattern)

        #:with self (generate-temporary #'self)
        #:with parser (generate-temporary #'parser)
        #:with base (generate-temporary #'base)
        #:with [attr/tmp ...] (generate-temporaries #'[attr.id ...])
        #:with [attr/dots ...] (stx-map arity->dots* #'[attr.id ...] #'[attr.arity ...])
        #:with [attr/nil ...] (stx-map (const #''()) #'[attr.id ...])

        #'{~and
           {~do (define parser
                  (syntax-parser
                    [{~and pattern ~!}
                     (let-values ([(base attr/tmp ...) (parser #'PH)])
                       (values base (cons #'attr/dots attr/tmp) ...))]
                    [_
                     (values this-syntax attr/nil ...)]))}
           self
           {~parse (PH (attr/dots (... ...)) ...)
                   (let-values ([(base attr/tmp ...) (parser #'self)])
                     (list base attr/tmp ...))}}]))))


;; ------------------------

(define-syntax uncurry
  (syntax-parser
    [(_ {~rec B #:binds (x)
              ({~literal λ} (x) B)})
     #'(λ (x ...) B)]))

(define f
  (uncurry (λ (A)
             (λ (B)
               (λ (C)
                 (+ B (* A C)))))))
(f 4 5 6)