cxr.rkt

#lang racket

(require (for-syntax racket/syntax)
         syntax/parse/define
         syntax/stx)

(begin-for-syntax
  (define-syntax-class a/d*r
    #:attributes [[a/d 1]]
    #:description "a sequence of ‘a’s and ‘d’s followed by a single ‘r’"
    [pattern x:id
             #:do [(define str (symbol->string (syntax-e #'x)))]
             #:when (regexp-match? #px"[ad]*r" str)
             #:with [a/d ...] (string->list (substring str 0 (sub1 (string-length str))))]))

(define-syntax-parser c-helper
  [(_ e)
   #'e]
  [(_ a/d ... #\a e)
   #'(c-helper a/d ... (car e))]
  [(_ a/d ... #\d e)
   #'(c-helper a/d ... (cdr e))])

(define-syntax-parser c
  [(_ {~and :a/d*r a/dr})
   #:with ca/dr ((make-syntax-introducer) (format-id #f "c~a" #'a/dr))
   #'(let ([ca/dr (lambda (x) (c-helper a/d ... x))]) ca/dr)]
  [(_ :a/d*r e)
   #'(c-helper a/d ... e)])