stxparse-pattern-fixpoint.rxt

#lang racket
(require syntax/parse
         syntax/parse/experimental/reflect
         (for-syntax racket/syntax
                     syntax/parse))
                     
;; Inspiration from @sorawee on the Racket Slack:
;; https://racket.slack.com/archives/C06V96CKX/p1561716378319300
;; > sorawee [6:06 AM]
;;   Is it possible to implement a fixpoint operator for `syntax/parse` pattern?
;;   E.g.,
;;   ```
;;   (syntax-parse #'(1 ((((2)))) 3)
;;     [(a {~fix f {~or* b:number (f)}} c) #'(a b c)]) ;=> #'(1 2 3)
;;   ```
;; > ryanc [6:36 AM]
;;   @sorawee That's what syntax classes are for.
;;   But there are no anonymous syntax classes or fixed-point patterns.

(begin-for-syntax
  (define (fix-name name-class)
    (pattern-expander
     (syntax-parser
       [name:id
        #:with blank (datum->syntax #'name '|| #'name #'name)
        #`{~var blank #,name-class}]
       [(name:id . rst)
        #:with blank (datum->syntax #'name '|| #'name #'name)
        #`({~var blank #,name-class} . rst)]))))

(define-syntax ~fix
  (pattern-expander
   (syntax-parser
     [(_ name:id pat
         {~optional {~seq #:attributes attrs} #:defaults ([attrs #'()])})
      #:with name-class (generate-temporary #'name)
      #:with blank (datum->syntax #'name '|| #'name #'name)
      #'{~reflect
         blank
         ((let ()
            (define-syntax name (fix-name (quote-syntax name-class)))
            (define-syntax-class name-class
              #:attributes attrs
              [pattern pat])
            (reify-syntax-class name-class)))
         #:attributes attrs}])))

(syntax-parse #'(1 ((((2)))) 3)
  [(a {~fix f {~or* b:number (f)} #:attributes [b]} c) #'(a b c)])